l4/pkg/ocaml/contrib/parsing/location.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the Q Public License version 1.0.               *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* $Id: location.ml 8768 2008-01-11 16:13:18Z doligez $ *)
  14
  15 open Lexing
  16
  17 type t = { loc_start: position; loc_end: position; loc_ghost: bool };;
  18
  19 let none = { loc_start = dummy_pos; loc_end = dummy_pos; loc_ghost = true };;
  20
  21 let in_file name =
  22   let loc = {
  23     pos_fname = name;
  24     pos_lnum = 1;
  25     pos_bol = 0;
  26     pos_cnum = -1;
  27   } in
  28   { loc_start = loc; loc_end = loc; loc_ghost = true }
  29 ;;
  30
  31 let curr lexbuf = {
  32   loc_start = lexbuf.lex_start_p;
  33   loc_end = lexbuf.lex_curr_p;
  34   loc_ghost = false
  35 };;
  36
  37 let init lexbuf fname =
  38   lexbuf.lex_curr_p <- {
  39     pos_fname = fname;
  40     pos_lnum = 1;
  41     pos_bol = 0;
  42     pos_cnum = 0;
  43   }
  44 ;;
  45
  46 let symbol_rloc () = {
  47   loc_start = Parsing.symbol_start_pos ();
  48   loc_end = Parsing.symbol_end_pos ();
  49   loc_ghost = false;
  50 };;
  51
  52 let symbol_gloc () = {
  53   loc_start = Parsing.symbol_start_pos ();
  54   loc_end = Parsing.symbol_end_pos ();
  55   loc_ghost = true;
  56 };;
  57
  58 let rhs_loc n = {
  59   loc_start = Parsing.rhs_start_pos n;
  60   loc_end = Parsing.rhs_end_pos n;
  61   loc_ghost = false;
  62 };;
  63
  64 let input_name = ref "_none_"
  65 let input_lexbuf = ref (None : lexbuf option)
  66
  67 (* Terminal info *)
  68
  69 let status = ref Terminfo.Uninitialised
  70
  71 let num_loc_lines = ref 0 (* number of lines already printed after input *)
  72
  73 (* Highlight the locations using standout mode. *)
  74
  75 let highlight_terminfo ppf num_lines lb loc1 loc2 =
  76   Format.pp_print_flush ppf ();  (* avoid mixing Format and normal output *)
  77   (* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *)
  78   let pos0 = -lb.lex_abs_pos in
  79   (* Do nothing if the buffer does not contain the whole phrase. *)
  80   if pos0 < 0 then raise Exit;
  81   (* Count number of lines in phrase *)
  82   let lines = ref !num_loc_lines in
  83   for i = pos0 to lb.lex_buffer_len - 1 do
  84     if lb.lex_buffer.[i] = '\n' then incr lines
  85   done;
  86   (* If too many lines, give up *)
  87   if !lines >= num_lines - 2 then raise Exit;
  88   (* Move cursor up that number of lines *)
  89   flush stdout; Terminfo.backup !lines;
  90   (* Print the input, switching to standout for the location *)
  91   let bol = ref false in
  92   print_string "# ";
  93   for pos = 0 to lb.lex_buffer_len - pos0 - 1 do
  94     if !bol then (print_string "  "; bol := false);
  95     if pos = loc1.loc_start.pos_cnum || pos = loc2.loc_start.pos_cnum then
  96       Terminfo.standout true;
  97     if pos = loc1.loc_end.pos_cnum || pos = loc2.loc_end.pos_cnum then
  98       Terminfo.standout false;
  99     let c = lb.lex_buffer.[pos + pos0] in
 100     print_char c;
 101     bol := (c = '\n')
 102   done;
 103   (* Make sure standout mode is over *)
 104   Terminfo.standout false;
 105   (* Position cursor back to original location *)
 106   Terminfo.resume !num_loc_lines;
 107   flush stdout
 108
 109 (* Highlight the location by printing it again. *)
 110
 111 let highlight_dumb ppf lb loc =
 112   (* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *)
 113   let pos0 = -lb.lex_abs_pos in
 114   (* Do nothing if the buffer does not contain the whole phrase. *)
 115   if pos0 < 0 then raise Exit;
 116   let end_pos = lb.lex_buffer_len - pos0 - 1 in
 117   (* Determine line numbers for the start and end points *)
 118   let line_start = ref 0 and line_end = ref 0 in
 119   for pos = 0 to end_pos do
 120     if lb.lex_buffer.[pos + pos0] = '\n' then begin
 121       if loc.loc_start.pos_cnum > pos then incr line_start;
 122       if loc.loc_end.pos_cnum   > pos then incr line_end;
 123     end
 124   done;
 125   (* Print character location (useful for Emacs) *)
 126   Format.fprintf ppf "Characters %i-%i:@."
 127                  loc.loc_start.pos_cnum loc.loc_end.pos_cnum;
 128   (* Print the input, underlining the location *)
 129   Format.pp_print_string ppf "  ";
 130   let line = ref 0 in
 131   let pos_at_bol = ref 0 in
 132   for pos = 0 to end_pos do
 133     let c = lb.lex_buffer.[pos + pos0] in
 134     if c <> '\n' then begin
 135       if !line = !line_start && !line = !line_end then
 136         (* loc is on one line: print whole line *)
 137         Format.pp_print_char ppf c
 138       else if !line = !line_start then
 139         (* first line of multiline loc: print ... before loc_start *)
 140         if pos < loc.loc_start.pos_cnum
 141         then Format.pp_print_char ppf '.'
 142         else Format.pp_print_char ppf c
 143       else if !line = !line_end then
 144         (* last line of multiline loc: print ... after loc_end *)
 145         if pos < loc.loc_end.pos_cnum
 146         then Format.pp_print_char ppf c
 147         else Format.pp_print_char ppf '.'
 148       else if !line > !line_start && !line < !line_end then
 149         (* intermediate line of multiline loc: print whole line *)
 150         Format.pp_print_char ppf c
 151     end else begin
 152       if !line = !line_start && !line = !line_end then begin
 153         (* loc is on one line: underline location *)
 154         Format.fprintf ppf "@.  ";
 155         for i = !pos_at_bol to loc.loc_start.pos_cnum - 1 do
 156           Format.pp_print_char ppf ' '
 157         done;
 158         for i = loc.loc_start.pos_cnum to loc.loc_end.pos_cnum - 1 do
 159           Format.pp_print_char ppf '^'
 160         done
 161       end;
 162       if !line >= !line_start && !line <= !line_end then begin
 163         Format.fprintf ppf "@.";
 164         if pos < loc.loc_end.pos_cnum then Format.pp_print_string ppf "  "
 165       end;
 166       incr line;
 167       pos_at_bol := pos + 1;
 168     end
 169   done
 170
 171 (* Highlight the location using one of the supported modes. *)
 172
 173 let rec highlight_locations ppf loc1 loc2 =
 174   match !status with
 175     Terminfo.Uninitialised ->
 176       status := Terminfo.setup stdout; highlight_locations ppf loc1 loc2
 177   | Terminfo.Bad_term ->
 178       begin match !input_lexbuf with
 179         None -> false
 180       | Some lb ->
 181           let norepeat =
 182             try Sys.getenv "TERM" = "norepeat" with Not_found -> false in
 183           if norepeat then false else
 184             try highlight_dumb ppf lb loc1; true
 185             with Exit -> false
 186       end
 187   | Terminfo.Good_term num_lines ->
 188       begin match !input_lexbuf with
 189         None -> false
 190       | Some lb ->
 191           try highlight_terminfo ppf num_lines lb loc1 loc2; true
 192           with Exit -> false
 193       end
 194
 195 (* Print the location in some way or another *)
 196
 197 open Format
 198
 199 let reset () =
 200   num_loc_lines := 0
 201
 202 let (msg_file, msg_line, msg_chars, msg_to, msg_colon, msg_head) =
 203   ("File \"", "\", line ", ", characters ", "-", ":", "")
 204
 205 (* return file, line, char from the given position *)
 206 let get_pos_info pos =
 207   let (filename, linenum, linebeg) =
 208     if pos.pos_fname = "" && !input_name = "" then
 209       ("", -1, 0)
 210     else if pos.pos_fname = "" then
 211       Linenum.for_position !input_name pos.pos_cnum
 212     else
 213       (pos.pos_fname, pos.pos_lnum, pos.pos_bol)
 214   in
 215   (filename, linenum, pos.pos_cnum - linebeg)
 216 ;;
 217
 218 let print ppf loc =
 219   let (file, line, startchar) = get_pos_info loc.loc_start in
 220   let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in
 221   let (startchar, endchar) =
 222     if startchar < 0 then (0, 1) else (startchar, endchar)
 223   in
 224   if file = "" then begin
 225     if highlight_locations ppf loc none then () else
 226       fprintf ppf "Characters %i-%i:@."
 227               loc.loc_start.pos_cnum loc.loc_end.pos_cnum
 228   end else begin
 229     fprintf ppf "%s%s%s%i" msg_file file msg_line line;
 230     fprintf ppf "%s%i" msg_chars startchar;
 231     fprintf ppf "%s%i%s@.%s" msg_to endchar msg_colon msg_head;
 232   end
 233 ;;
 234
 235 let print_error ppf loc =
 236   print ppf loc;
 237   fprintf ppf "Error: ";
 238 ;;
 239
 240 let print_error_cur_file ppf = print_error ppf (in_file !input_name);;
 241
 242 let print_warning loc ppf w =
 243   if Warnings.is_active w then begin
 244     let printw ppf w =
 245       let n = Warnings.print ppf w in
 246       num_loc_lines := !num_loc_lines + n
 247     in
 248     fprintf ppf "%a" print loc;
 249     fprintf ppf "Warning %a@." printw w;
 250     pp_print_flush ppf ();
 251     incr num_loc_lines;
 252   end
 253 ;;
 254
 255 let prerr_warning loc w = print_warning loc err_formatter w;;
 256
 257 let echo_eof () =
 258   print_newline ();
 259   incr num_loc_lines