
(* Notes:
This code is strangely brittle with respect to the what \n represents.
The lexer counts \n as one character, but seek uses the actual number of characters used to represent it.  Since \n is represented by 2 characters on NT this leads to seek being wrong unless we correct the values given by the lexer by the number of lines.

Right now this is hacked up so that it works as long as the file has been written on NT.  But if the file came from Unix it is not going to work.  A more robust solution is needed.
*)

module X = Poperr ;;
module U = Utilities ;;
module L = Poplocus ;;

exception ErrorError of unit ;; (* Error in the error handling!!! *)

let error_condition = ref false ;;
let first_error = ref true ;; (* We expect to handle multiple errors before aborting. *)

let fname = ref "" ;;
let seekable = ref false ;;
let instream = ref None ;;
let error_stream = ref stdout ;;
let supress_level = ref 5 ;; (* supress everything above level 5 by default. *)

let line_table = ref None;; (* The table has not been built yet. *)

let pr = (output_string !error_stream) ;; (* Errors should be printed with pr. *)
let pr_char = (output_char !error_stream) ;;
let rec pr_spaces n = match(n) with 0 -> () | n -> (pr " "; pr_spaces (n-1)) ;;
let pr_int i = (pr (string_of_int i));;

let set_filename str is_seekable =
   (
   (match !instream with
       None -> ()
     | Some s -> close_in s);
   instream := None;
   seekable := is_seekable;
   fname := str;
   line_table := None;
   )
;; 
let rec find_line chan char_pos =
  begin
   let rec aux curr_pos curr_line = 
      begin
	try
	  let s = input_line chan in
	  let s_len = String.length s in
	  
	  if (curr_pos+s_len) >= char_pos
	  then (s, curr_line, curr_pos,curr_pos+s_len)
	  else
	     (aux (pos_in chan) (curr_line+1))
	with End_of_file -> (pr ("poperrhandle.ml: no such line." ^ string_of_int char_pos); 
			     raise (ErrorError()))
      end in
   seek_in chan 0;
   aux 0 1
  end

(* get_context takes the start character and the end character and returns a 
   one line context to emit that shows where error occurred in the file. *)
let get_context char_start char_end =
begin
  let in_chan = (open_in !fname) in
  let (sl_line,sl,sl_start,sl_end) = find_line in_chan char_start in
  let (el_line,el,el_start,el_end) = find_line in_chan char_end in
  let len_start = (char_start - sl_start) in
  let len_end = (el_end - char_end) in
  let len_mid = (char_end - char_start) in
  let pos_end = (char_end - sl_start) in
  let sl_len_end = (sl_end - char_start) in
  let el_len_start = (char_end - el_start) in
  let _ = (close_in in_chan) in
  let trunc n s = 
    (if (String.length s ) <=n then s
    else
      try
      	let len = (String.length s) in
      	let cut = (len - (n-3)) in
      	let len_two = len - ((len+cut)/2) in
      	let sec_one = (String.sub s 0 ((len-cut)/2)) in
      	let sec_two = (String.sub s ((len+cut)/2) len_two) in
      	(sec_one ^ "..." ^ sec_two)
      with Invalid_argument s -> (raise (Invalid_argument ("trunc " ^ s)))
	  ) in
  
  (* assert char_start < char_end *)
  if (sl=el)
  then (* short and easy. *)
    try
      let sec_one = (String.sub sl_line 0 len_start) in
      let sec_two = (String.sub sl_line len_start len_mid) in
      let sec_three = (String.sub sl_line pos_end len_end) in
      let trunc s = (trunc 20 s) in
      (sl,el,(trunc sec_one) ^ "[[" ^ (trunc sec_two) ^ "]]" ^ (trunc sec_three))
    with Invalid_argument s -> (raise (Invalid_argument ("get_context: easy: " ^s)))
  else
    (
    try
      let sec_one = (String.sub sl_line 0 len_start) in
      let sec_two = (String.sub sl_line len_start sl_len_end) in
      let sec_three = (String.sub el_line 0 el_len_start) in
      let sec_four = (String.sub el_line el_len_start len_end) in
      let trunc s = (trunc 15 s) in
      (sl,el, 
       (trunc sec_one) ^ "[[" ^ (trunc sec_two) ^ ".\\." ^ 
       (trunc sec_three) ^ "]]" ^ (trunc sec_four))
    with Invalid_argument s -> 
      (raise (Invalid_argument ("get_context: hard: " ^s))))
      
end;;

let get_errortype t =
  (match t with
      X.ETwarning(x) -> ("Warning(" ^ string_of_int(x) ^ ")")
    | X.ETerror   -> "Error"
    | X.ETpedantic -> "Pedantic"
    | X.ETcomment -> "Comment"
  )
;;

let signal_error etype loc =
  begin
    if X.error_level(etype) < !supress_level then
      begin
   	(if (!first_error) then 
	  (pr "Errors found in file \"";
	   pr !fname;
	   pr "\"\n";    
	   first_error := false; ));
  	
        (let et = X.error_type(etype) in
	(match X.error_type(etype) with
       	  X.ETerror -> error_condition:=true
        | _ -> ());
    	pr (get_errortype et));

   	pr ": ";
   	pr (X.error_message etype);
   	pr "\n";
   	(match L.get loc with
	  None -> ()
     	| Some (start, finish) ->
	    let (start_line,end_line,context) = get_context start finish
            in
 	    if false then ()
       	    else
              begin
	        pr_spaces 2; 
	        pr (string_of_int start_line);
	        pr "-";
	        pr (string_of_int end_line);
	        pr "> ";
                (if X.is_verbose(etype) then 
      	          (pr context; pr "\n"));
      	        ()
	      end
		);
      end
  end;;
    

