diff options
| -rw-r--r-- | typing/env.ml | 46 | ||||
| -rw-r--r-- | typing/env.mli | 3 | ||||
| -rw-r--r-- | typing/includecore.ml | 5 | ||||
| -rw-r--r-- | typing/typecore.ml | 1 |
4 files changed, 47 insertions, 8 deletions
diff --git a/typing/env.ml b/typing/env.ml index ad4721c415..64a8963e1b 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -32,6 +32,8 @@ 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 error = Not_an_interface of string | Wrong_version_interface of string * string @@ -503,11 +505,15 @@ and lookup_cltype = lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) let mark_value_used name vd = - try Hashtbl.find value_declarations (name, vd.val_loc) (); + try Hashtbl.find value_declarations (name, vd.val_loc) () with Not_found -> () let mark_type_used name vd = - try Hashtbl.find type_declarations (name, vd.type_loc) (); + 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) () with Not_found -> () let set_value_used_callback name vd callback = @@ -540,18 +546,24 @@ let mark_type_path env path = let decl = try find_type path env with Not_found -> assert false in mark_type_used (Path.last path) decl -let mark_type_constr env = function - | {desc=Tconstr(path, _, _)} -> mark_type_path env path +let ty_path = function + | {desc=Tconstr(path, _, _)} -> path | _ -> assert false let lookup_constructor lid env = let desc = lookup_constructor lid env in - mark_type_constr env desc.cstr_res; + mark_type_path env (ty_path desc.cstr_res); desc +let mark_constructor env name desc = + 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 + let lookup_label lid env = let desc = lookup_label lid env in - mark_type_constr env desc.lbl_res; + mark_type_path env (ty_path desc.lbl_res); desc let lookup_class lid env = @@ -814,9 +826,27 @@ and store_annot id path annot env = else env and store_type id path info env = - check_usage info.type_loc id (fun s -> Warnings.Unused_type_declaration s) type_declarations; + let loc = info.type_loc in + check_usage loc id (fun s -> Warnings.Unused_type_declaration s) type_declarations; let constructors = constructors_of_type path info in - let labels = labels_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 + 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); + !add_delayed_check_forward + (fun () -> + if not !used then + Location.prerr_warning loc (Warnings.Unused_constructor c) + ) + ) + constructors + end; { env with constrs = List.fold_right diff --git a/typing/env.mli b/typing/env.mli index 4e8126ceff..9323047c35 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -154,6 +154,9 @@ 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 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 78348eb408..7f319af1fb 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -206,6 +206,11 @@ let type_declarations env id decl1 decl2 = let err = match (decl1.type_kind, decl2.type_kind) with (_, Type_abstract) -> [] | (Type_variant cstrs1, Type_variant cstrs2) -> + let name = Ident.name id in + if decl1.type_private = Private || decl2.type_private = Public then + List.iter + (fun (c, _, _) -> Env.mark_constructor_used 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/typecore.ml b/typing/typecore.ml index 47d30c74f0..a400bc23ea 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -2419,6 +2419,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; let sargs = match sarg with None -> [] |