Improve message for Unused constructor/exception warnings.

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@12371 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

8 files changed, 78 insertions, 34 deletions

diff --git a/typing/env.ml b/typing/env.ml
index 53afa5a9e..f26369207 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -32,7 +32,21 @@ let value_declarations : ((string * Location.t), (unit -> unit)) Hashtbl.t = Has
 
 let type_declarations = Hashtbl.create 16
 
-let used_constructors : (string * Location.t * string, (unit -> unit)) Hashtbl.t = Hashtbl.create 16
+type constructor_usage = [`Positive|`Pattern|`Privatize]
+type constructor_usages =
+    {
+     mutable cu_positive: bool;
+     mutable cu_pattern: bool;
+     mutable cu_privatize: bool;
+    }
+let add_constructor_usage cu = function
+  | `Positive -> cu.cu_positive <- true
+  | `Pattern -> cu.cu_pattern <- true
+  | `Privatize -> cu.cu_privatize <- true
+let constructor_usages () =
+  {cu_positive = false; cu_pattern = false; cu_privatize = false}
+
+let used_constructors : (string * Location.t * string, (constructor_usage -> unit)) Hashtbl.t = Hashtbl.create 16
 
 type error =
     Not_an_interface of string
@@ -527,12 +541,12 @@ let mark_type_used name vd =
   try Hashtbl.find type_declarations (name, vd.type_loc) ()
   with Not_found -> ()
 
-let mark_constructor_used name vd constr =
-  try Hashtbl.find used_constructors (name, vd.type_loc, constr) ()
+let mark_constructor_used usage name vd constr =
+  try Hashtbl.find used_constructors (name, vd.type_loc, constr) usage
   with Not_found -> ()
 
-let mark_exception_used ed constr =
-  try Hashtbl.find used_constructors ("exn", ed.exn_loc, constr) ()
+let mark_exception_used usage ed constr =
+  try Hashtbl.find used_constructors ("exn", ed.exn_loc, constr) usage
   with Not_found -> ()
 
 let set_value_used_callback name vd callback =
@@ -574,18 +588,18 @@ let lookup_constructor lid env =
   mark_type_path env (ty_path desc.cstr_res);
   desc
 
-let mark_constructor env name desc =
+let mark_constructor usage env name desc =
   match desc.cstr_tag with
   | Cstr_exception (_, loc) ->
       begin
-        try Hashtbl.find used_constructors ("exn", loc, name) ()
+        try Hashtbl.find used_constructors ("exn", loc, name) usage
         with Not_found -> ()
       end
   | _ ->
       let ty_path = ty_path desc.cstr_res in
       let ty_decl = try find_type ty_path env with Not_found -> assert false in
       let ty_name = Path.last ty_path in
-      mark_constructor_used ty_name ty_decl name
+      mark_constructor_used usage ty_name ty_decl name
 
 let lookup_label lid env =
   let desc = lookup_label lid env in
@@ -857,19 +871,24 @@ and store_type id path info env =
   let constructors = constructors_of_type path info in
   let labels = labels_of_type path info in
 
-  if not loc.Location.loc_ghost && Warnings.is_active (Warnings.Unused_constructor "") then begin
+  if not loc.Location.loc_ghost &&
+    Warnings.is_active (Warnings.Unused_constructor ("", false, false))
+  then begin
     let ty = Ident.name id in
     List.iter
       (fun (c, _) ->
         let k = (ty, loc, c) in
         if not (Hashtbl.mem used_constructors k) then
-          let used = ref false in
-          Hashtbl.add used_constructors k (fun () -> used := true);
+          let used = constructor_usages () in
+          Hashtbl.add used_constructors k (add_constructor_usage used);
           if not (ty = "" || ty.[0] = '_')
           then !add_delayed_check_forward
               (fun () ->
-                if not !used then
-                  Location.prerr_warning loc (Warnings.Unused_constructor c)
+                if not used.cu_positive then
+                  Location.prerr_warning loc
+                    (Warnings.Unused_constructor
+                       (c, used.cu_pattern, used.cu_privatize)
+                    )
               )
       )
       constructors
@@ -906,17 +925,22 @@ and store_type_infos id path info env =
 
 and store_exception id path decl env =
   let loc = decl.exn_loc in
-  if not loc.Location.loc_ghost && Warnings.is_active (Warnings.Unused_exception "") then begin
+  if not loc.Location.loc_ghost &&
+    Warnings.is_active (Warnings.Unused_exception ("", false))
+  then begin
     let ty = "exn" in
     let c = Ident.name id in
     let k = (ty, loc, c) in
     if not (Hashtbl.mem used_constructors k) then begin
-      let used = ref false in
-      Hashtbl.add used_constructors k (fun () -> used := true);
+      let used = constructor_usages () in
+      Hashtbl.add used_constructors k (add_constructor_usage used);
       !add_delayed_check_forward
         (fun () ->
-          if not !used then
-            Location.prerr_warning loc (Warnings.Unused_exception c)
+          if not used.cu_positive then
+            Location.prerr_warning loc
+              (Warnings.Unused_exception
+                 (c, used.cu_pattern)
+              )
         )
     end;
   end;
diff --git a/typing/env.mli b/typing/env.mli
index 21a469d14..0c5f515c3 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -153,11 +153,14 @@ open Format
 
 val report_error: formatter -> error -> unit
 
+
 val mark_value_used: string -> value_description -> unit
 val mark_type_used: string -> type_declaration -> unit
-val mark_constructor_used: string -> type_declaration -> string -> unit
-val mark_constructor: t -> string -> constructor_description -> unit
-val mark_exception_used: exception_declaration -> string -> unit
+
+type constructor_usage = [`Positive|`Pattern|`Privatize]
+val mark_constructor_used: constructor_usage -> string -> type_declaration -> string -> unit
+val mark_constructor: constructor_usage -> t -> string -> constructor_description -> unit
+val mark_exception_used: constructor_usage -> exception_declaration -> string -> unit
 
 val set_value_used_callback: string -> value_description -> (unit -> unit) -> unit
 val set_type_used_callback: string -> type_declaration -> ((unit -> unit) -> unit) -> unit
diff --git a/typing/includecore.ml b/typing/includecore.ml
index 972102af8..55113e1b0 100644
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -206,10 +206,13 @@ let type_declarations env name decl1 id decl2 =
   let err = match (decl1.type_kind, decl2.type_kind) with
       (_, Type_abstract) -> []
     | (Type_variant cstrs1, Type_variant cstrs2) ->
-        if decl1.type_private = Private || decl2.type_private = Public then
-          List.iter
-            (fun (c, _, _) -> Env.mark_constructor_used name decl1 c)
-            cstrs1;
+        let usage =
+          if decl1.type_private = Private || decl2.type_private = Public
+          then `Positive else `Privatize
+        in
+        List.iter
+          (fun (c, _, _) -> Env.mark_constructor_used usage name decl1 c)
+          cstrs1;
         compare_variants env decl1 decl2 1 cstrs1 cstrs2
     | (Type_record(labels1,rep1), Type_record(labels2,rep2)) ->
         let err = compare_records env decl1 decl2 1 labels1 labels2 in
diff --git a/typing/includemod.ml b/typing/includemod.ml
index f1e87f55a..26f27a6f2 100644
--- a/typing/includemod.ml
+++ b/typing/includemod.ml
@@ -69,7 +69,7 @@ let type_declarations env cxt subst id decl1 decl2 =
 (* Inclusion between exception declarations *)
 
 let exception_declarations env cxt subst id decl1 decl2 =
-  Env.mark_exception_used decl1 (Ident.name id);
+  Env.mark_exception_used `Positive decl1 (Ident.name id);
   let decl2 = Subst.exception_declaration subst decl2 in
   if Includecore.exception_declarations env decl1 decl2
   then ()
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 1a8b8db1d..a4aa5179e 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -666,6 +666,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
             Hashtbl.find constrs s
         | _ ->  Typetexp.find_constructor !env loc lid
       in
+      Env.mark_constructor `Pattern !env (Longident.last lid) constr;
       if no_existentials && constr.cstr_existentials <> [] then
         raise (Error (loc, Unexpected_existential));
       (* if constructor is gadt, we must verify that the expected type has the
@@ -2569,7 +2570,7 @@ and type_application env funct sargs =
 
 and type_construct env loc lid sarg explicit_arity ty_expected =
   let constr = Typetexp.find_constructor env loc lid in
-  Env.mark_constructor env (Longident.last lid) constr;
+  Env.mark_constructor `Positive env (Longident.last lid) constr;
   let sargs =
     match sarg with
       None -> []
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 307d5041b..cfcf55126 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -844,7 +844,7 @@ let transl_exn_rebind env loc lid =
       Env.lookup_constructor lid env
     with Not_found ->
       raise(Error(loc, Unbound_exception lid)) in
-  Env.mark_constructor env (Longident.last lid) cdescr;
+  Env.mark_constructor `Positive env (Longident.last lid) cdescr;
   match cdescr.cstr_tag with
     Cstr_exception (path, _) ->
       (path, {exn_args = cdescr.cstr_args; exn_loc = loc})
diff --git a/utils/warnings.ml b/utils/warnings.ml
index 4745598b0..0a950923d 100644
--- a/utils/warnings.ml
+++ b/utils/warnings.ml
@@ -56,8 +56,8 @@ type t =
   | Unused_type_declaration of string       (* 34 *)
   | Unused_for_index of string              (* 35 *)
   | Unused_ancestor of string               (* 36 *)
-  | Unused_constructor of string            (* 37 *)
-  | Unused_exception of string              (* 38 *)
+  | Unused_constructor of string * bool * bool  (* 37 *)
+  | Unused_exception of string * bool       (* 38 *)
 ;;
 
 (* If you remove a warning, leave a hole in the numbering.  NEVER change
@@ -285,8 +285,21 @@ let message = function
   | Unused_type_declaration s -> "unused type " ^ s ^ "."
   | Unused_for_index s -> "unused for-loop index " ^ s ^ "."
   | Unused_ancestor s -> "unused ancestor variable " ^ s ^ "."
-  | Unused_constructor s -> "unused constructor " ^ s ^ "."
-  | Unused_exception s -> "unused exception constructor " ^ s ^ "."
+  | Unused_constructor (s, false, false) -> "unused constructor " ^ s ^ "."
+  | Unused_constructor (s, true, _) ->
+      "constructor " ^ s ^
+      " is never used to build values.\n\
+        (However, this constructor appears in patterns.)"
+  | Unused_constructor (s, false, true) ->
+      "constructor " ^ s ^
+      " is never used to build values.\n\
+        Its type is exported as a private type."
+  | Unused_exception (s, false) ->
+      "unused exception constructor " ^ s ^ "."
+  | Unused_exception (s, true) ->
+      "exception constructor " ^ s ^
+      " is never raised or used to build values.\n\
+        (However, this constructor appears in patterns.)"
 ;;
 
 let nerrors = ref 0;;
diff --git a/utils/warnings.mli b/utils/warnings.mli
index 6cb7ce561..c7542af8c 100644
--- a/utils/warnings.mli
+++ b/utils/warnings.mli
@@ -51,8 +51,8 @@ type t =
   | Unused_type_declaration of string       (* 34 *)
   | Unused_for_index of string              (* 35 *)
   | Unused_ancestor of string               (* 36 *)
-  | Unused_constructor of string            (* 37 *)
-  | Unused_exception of string              (* 38 *)
+  | Unused_constructor of string * bool * bool  (* 37 *)
+  | Unused_exception of string * bool       (* 38 *)
 ;;
 
 val parse_options : bool -> string -> unit;;