
module Id = Identifier ;;

type id = Id.identifier ;;

(* To create a new kind of compiler error you have to modify the types in this
   file appropriately and update the various functions that produce strings. 
   Poperrhandle.ml is responsible for outputing errors in a consistent manner, so do
   not format strings that you return with spaces or carriage returns. *)

type lexerError =
    IllegalStringCharacter of string 
  | RunawayComment
  | RunawayString
  | InvalidHexNum
  | InvalidChar
  | NonWhitespace of string
;;

type parseError =
    Syntax of string
  | SwitchClausesDontMatch
  | ExternNoInit
  | ParseUnimplemented 
  ;;

type tcError =
    Unimplemented of string
  | Impossible
  | TypeError of string

type tcWarn =
    WshadowVar of id
  ;;

type error =
    Eparse of parseError
  | Elexer of lexerError
  | Etypecheck of tcError
  | Wtypecheck of tcWarn
  | Eimpos of string
  ;;


exception CompilerError of (error * Poplocus.locus) ;;

let impos s = CompilerError(Eimpos s,Poplocus.none) ;;

type errorType =
    ETwarning of int
  | ETerror
  | ETpedantic
  | ETcomment
;;
 
let error_type e =
  match e with
     Eparse(_) -> ETerror
   | Elexer(_) -> ETerror
   | Etypecheck(_) -> ETerror
   | Wtypecheck(_) -> ETwarning(10)
   | Eimpos(_) -> ETerror
(*   | _ -> ETerror *)
;;

let error_message e =
  match e with
      Eparse(pe) ->
      	(
	  match pe with
	    Syntax s -> s
	  | SwitchClausesDontMatch -> "Switch clauses don't match."
	  | ExternNoInit -> "External value declarations cannot have initializers"
	  | ParseUnimplemented -> "Unimplemented"
        ) 
    | Elexer(le) -> 
      	( match(le) with
	    IllegalStringCharacter(s) -> "Illegal string character in string: \" " ^ s ^ "\""
	  | RunawayComment -> "Runaway comment."
	  | RunawayString -> "Runaway string."
	  | InvalidHexNum -> "Invalid hexadecimal number."
	  | InvalidChar -> "Invalid character code."
	  | NonWhitespace s -> ("Not valid whitespace ASCII: " ^ 
  (string_of_int (Char.code (String.get s 0))))
      	)
    | Etypecheck (tce) ->
        (
	 match tce with
	    Unimplemented s -> ("Typechecking : " ^ s ^ " unimplemented.")
	  | Impossible -> ("Impossible!!!")
	  | TypeError s -> ("Type error: " ^ s)
	)
    | Wtypecheck wtc ->
	(match wtc with
	   WshadowVar i -> ("Variable " ^ (Id.id_to_string i) ^ " shadowed.")
	       )
    | Eimpos s -> ("Impossible!! " ^ s)
(*    | _ -> "" *)
;;

let is_verbose e =
  match e with
    _ -> true
;;

let error_level e =
 (match(e) with
      Eparse(pe) -> 1
    | Elexer(le) -> 1
    | Etypecheck(tce) -> 1
    | _ -> 0
 );;
