(***********************************************************************)
(*                                                                     *)
(*                           Objective Caml                            *)
(*                                                                     *)
(*            Pierre Weis && Damien Doligez, INRIA Rocquencourt        *)
(*                                                                     *)
(*  Copyright 1998 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)

(* $Id$ *)

type t =
  | Partial_match of string          (* P *)
  | Unused_match                     (* U *)
  | Method_override of string list   (* M *)
  | Hide_instance_variable of string (* V *)
  | Partial_application              (* F *)
  | Statement_type                   (* S *)
  | Comment of string                (* C *)
  | Other of string                  (* X *)
;;

let pflag = ref true;;
let uflag = ref true;;
let mflag = ref true;;
let vflag = ref true;;
let fflag = ref true;;
let sflag = ref true;;
let cflag = ref true;;
let xflag = ref true;;

let rec parse_options s =
  for i = 0 to String.length s - 1 do
    match s.[i] with
    | 'P' -> pflag := true
    | 'p' -> pflag := false
    | 'U' -> uflag := true
    | 'u' -> uflag := false
    | 'M' -> mflag := true
    | 'm' -> mflag := false
    | 'V' -> vflag := true
    | 'v' -> vflag := false
    | 'F' -> fflag := true
    | 'f' -> fflag := false
    | 'S' -> sflag := true
    | 's' -> sflag := false
    | 'C' -> cflag := true
    | 'c' -> cflag := false
    | 'X' -> xflag := true
    | 'x' -> xflag := false
    | 'A' -> parse_options "PUMVFSX"
    | 'a' -> parse_options "pumvfsx"
    | c -> raise (Arg.Bad (Printf.sprintf "unknown warning option %c" c))
  done
;;

let is_active = function
  | Partial_match _ -> !pflag
  | Unused_match -> !uflag
  | Method_override _ -> !mflag
  | Hide_instance_variable _ -> !vflag
  | Partial_application -> !fflag
  | Statement_type -> !sflag
  | Comment _ -> !cflag
  | Other _ -> !xflag
;;

let message = function
  | Partial_match "" -> "this pattern-matching is not exhaustive."
  | Partial_match s ->
      "this pattern-matching is not exhaustive.\n\
       Here is an example of a value that is not matched:\n" ^ s
  | Unused_match -> "this match case is unused."
  | Method_override slist ->
      String.concat " "
        ("the following methods are overriden \
          by the inherited class:\n " :: slist)
  | Hide_instance_variable lab ->
      "this definition of an instance variable " ^ lab ^
      " hides a previously\ndefined instance variable of the same name."
  | Partial_application ->
      "this function application is partial,\n\
       maybe some arguments are missing."
  | Statement_type ->
      "this expression should have type unit."
  | Comment s -> "this is " ^ s ^ "."
  | Other s -> s
;;