(*
   errormsg.ml
   15-411
   by Benjamin Vernot, Peter Lee, Roland Flury
*)
(* @version $Id: errormsg.ml,v 1.3 2004/10/30 19:33:22 ajo Exp $ *)

(***********************************************************************)
(* Flags, debug-printing *)
(***********************************************************************)
(* The type of a position *)
type pos = (int * int)

(* debug printing *)
let debug = ref false

let print_debug s = if (!debug) then (
  Pervasives.print_string s;
  Pervasives.flush stdout
 )

let debugf fmt_etc =
  let k result = (print_debug result; "")
  in
  Printf.kprintf k fmt_etc

(* Print warnings *)
let warningFlag = ref false

(***********************************************************************)
(* Implementation of errormsg *)
(***********************************************************************)

let lineNum = ref 1
let linePos = ref [1]

type linePosT =
  | Pos of int
  | PosNewFile of int * int * string

type info = {
    mutable  linenum: int;
    mutable  linepos: linePosT list;
    mutable  fileName: string;
    mutable  errors: int;
    mutable  warnings: int;
}

let current : info = {
    linenum  = 1;
    linepos  = [Pos(1)];
    fileName = "";
    errors = 0;
    warnings = 0;
}

(***********************************************************************)
(* Functions that are called from within the lexer *)
(***********************************************************************)

(* Initialize current-struct mainly with file-name *)
let startFile fname =
  current.linenum  <- 1     ;
  current.linepos  <- [Pos(0)]   ;
  current.fileName <- fname ;
  current.errors   <- 0

(* Called for each newline *)
let startNewline n =
  current.linenum <- current.linenum + 1;
  current.linepos <- current.linepos @ [Pos(n)]

(* Called when a new file is scanned *)
let startNewFile n fname startLine =
  current.linenum <- current.linenum + 1;
  current.linepos <- current.linepos @ [PosNewFile(n, startLine, fname)]

(***********************************************************************)
(* Functions to retrieve information *)
(***********************************************************************)

(*
   Creates a string <filename>:<line:offset-line:offset>
*)
let getLocation (i : info) spos epos =
  let rec look line prev = function
    | Pos(a)::_ when (spos < a) -> (line, spos-prev-1, line, epos-prev-1)
    | [Pos(a)] -> (line+1, spos-a-1, line+1, epos-a-1)
    | Pos(a)::tail -> look (line+1) a tail
    | PosNewFile(a, l, n)::tail-> i.fileName <- n; look l a tail
    | [] -> (1, spos-prev-1, 1, epos-prev-1)
  in
  let (lin,col,lin2,col2) = look 0 0 i.linepos in
  if col2 < 0 then
    Printf.sprintf "%s" i.fileName
  else if lin=lin2 && col=col2 then
    Printf.sprintf "%s:%d.%d" i.fileName lin col
  else
    Printf.sprintf "%s:%d.%d-%d.%d" i.fileName lin col lin2 col2


(***********************************************************************)
(* Error messages *)
(***********************************************************************)

(* Prints an error message *)
let error (startpos, endpos) msg =
  current.errors <- current.errors + 1;
  Printf.eprintf "%s:\n  error: %s\n" (getLocation current startpos endpos) msg

(* Prints a warning *)
let warning (startpos, endpos) msg =
  if(!warningFlag) then (
    current.warnings <- current.warnings + 1;
    Printf.eprintf "%s:\n  warning: %s\n" (getLocation current startpos endpos) msg
  )

let current_errors () = current.errors
let current_warnings () = current.warnings