Detect unused module declarations.

6 files changed, 60 insertions, 25 deletions

diff --git a/typing/env.ml b/typing/env.ml
index ec9d57ada8..68f8eba96f 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -35,6 +35,7 @@ let value_declarations : ((string * Location.t), (unit -> unit)) Hashtbl.t =
        cf Includemod.value_descriptions). *)
 
 let type_declarations = Hashtbl.create 16
+let module_declarations = Hashtbl.create 16
 
 type constructor_usage = Positive | Pattern | Privatize
 type constructor_usages =
@@ -188,6 +189,7 @@ type t = {
 and module_components =
   {
     deprecated: string option;
+    loc: Location.t;
     comps: (t * Subst.t * Path.t * Types.module_type, module_components_repr)
            EnvLazy.t;
   }
@@ -305,8 +307,9 @@ let diff env1 env2 =
 (* Forward declarations *)
 
 let components_of_module' =
-  ref ((fun ~deprecated:_ _env _sub _path _mty -> assert false) :
-         deprecated:string option -> t -> Subst.t -> Path.t -> module_type ->
+  ref ((fun ~deprecated:_ ~loc:__env _sub _path _mty -> assert false) :
+         deprecated:string option -> loc:Location.t -> t -> Subst.t ->
+       Path.t -> module_type ->
        module_components)
 let components_of_module_maker' =
   ref ((fun (_env, _sub, _path, _mty) -> assert false) :
@@ -409,7 +412,8 @@ let read_pers_struct check modname filename =
       flags
   in
   let comps =
-      !components_of_module' ~deprecated empty Subst.identity
+      !components_of_module' ~deprecated ~loc:Location.none
+        empty Subst.identity
                              (Pident(Ident.create_persistent name))
                              (Mty_signature sign)
   in
@@ -503,6 +507,7 @@ let reset_cache () =
   clear_imports ();
   Hashtbl.clear value_declarations;
   Hashtbl.clear type_declarations;
+  Hashtbl.clear module_declarations;
   Hashtbl.clear used_constructors;
   Hashtbl.clear prefixed_sg
 
@@ -516,6 +521,7 @@ let reset_cache_toplevel () =
   List.iter (Hashtbl.remove persistent_structures) l;
   Hashtbl.clear value_declarations;
   Hashtbl.clear type_declarations;
+  Hashtbl.clear module_declarations;
   Hashtbl.clear used_constructors;
   Hashtbl.clear prefixed_sg
 
@@ -790,6 +796,11 @@ let report_deprecated ?loc p deprecated =
                                 (Path.name p) txt))
   | _ -> ()
 
+let mark_module_used env name loc =
+  if not (is_implicit_coercion env) then
+    try Hashtbl.find module_declarations (name, loc) ()
+    with Not_found -> ()
+
 let rec lookup_module_descr_aux ?loc lid env =
   match lid with
     Lident s ->
@@ -823,6 +834,11 @@ let rec lookup_module_descr_aux ?loc lid env =
 
 and lookup_module_descr ?loc lid env =
   let (p, comps) as res = lookup_module_descr_aux ?loc lid env in
+  mark_module_used env (Path.last p) comps.loc;
+(*
+  Format.printf "USE module %s at %a@." (Path.last p)
+    Location.print comps.loc;
+*)
   report_deprecated ?loc p comps.deprecated;
   res
 
@@ -830,7 +846,10 @@ and lookup_module ~load ?loc lid env : Path.t =
   match lid with
     Lident s ->
       begin try
-        let (p, {md_type; md_attributes}) = EnvTbl.find_name s env.modules in
+        let (p, {md_type; md_attributes; md_loc}) =
+          EnvTbl.find_name s env.modules
+        in
+        mark_module_used env s md_loc;
         begin match md_type with
         | Mty_ident (Path.Pident id) when Ident.name id = "#recmod#" ->
           (* see #5965 *)
@@ -1367,9 +1386,10 @@ let add_to_tbl id decl tbl =
     try Tbl.find id tbl with Not_found -> [] in
   Tbl.add id (decl :: decls) tbl
 
-let rec components_of_module ~deprecated env sub path mty =
+let rec components_of_module ~deprecated ~loc env sub path mty =
   {
     deprecated;
+    loc;
     comps = EnvLazy.create (env, sub, path, mty)
   }
 
@@ -1430,10 +1450,10 @@ and components_of_module_maker (env, sub, path, mty) =
             let deprecated =
               Builtin_attributes.deprecated_of_attrs md.md_attributes
             in
-            let comps = components_of_module ~deprecated !env sub path mty in
+            let comps = components_of_module ~deprecated ~loc:md.md_loc !env sub path mty in
             c.comp_components <-
               Tbl.add (Ident.name id) (comps, !pos) c.comp_components;
-            env := store_module None id (Pident id) md !env !env;
+            env := store_module ~check:false None id (Pident id) md !env !env;
             incr pos
         | Sig_modtype(id, decl) ->
             let decl' = Subst.modtype_declaration sub decl in
@@ -1593,14 +1613,19 @@ and store_extension ~check slot id path ext env renv =
                 env.constrs renv.constrs;
     summary = Env_extension(env.summary, id, ext) }
 
-and store_module slot id path md env renv =
+and store_module ~check slot id path md env renv =
+  let loc = md.md_loc in
+  if check then
+    check_usage loc id (fun s -> Warnings.Unused_module s)
+      module_declarations;
+
   let deprecated = Builtin_attributes.deprecated_of_attrs md.md_attributes in
   { env with
     modules = EnvTbl.add slot (fun x -> `Module x) id (path, md)
         env.modules renv.modules;
     components =
       EnvTbl.add slot (fun x -> `Component x) id
-        (path, components_of_module ~deprecated
+        (path, components_of_module ~deprecated ~loc:md.md_loc
            env Subst.identity path md.md_type)
         env.components renv.components;
     summary = Env_module(env.summary, id, md) }
@@ -1632,7 +1657,8 @@ let components_of_functor_appl f env p1 p2 =
     let p = Papply(p1, p2) in
     let sub = Subst.add_module f.fcomp_param p2 Subst.identity in
     let mty = Subst.modtype sub f.fcomp_res in
-    let comps = components_of_module ~deprecated:None (*???*)
+    let comps = components_of_module ~deprecated:None ~loc:Location.none
+        (*???*)
         env Subst.identity p mty in
     Hashtbl.add f.fcomp_cache p2 comps;
     comps
@@ -1660,13 +1686,13 @@ let add_type ~check id info env =
 and add_extension ~check id ext env =
   store_extension ~check None id (Pident id) ext env env
 
-and add_module_declaration ?(arg=false) id md env =
+and add_module_declaration ?(arg=false) ~check id md env =
   let path =
     (*match md.md_type with
       Mty_alias path -> normalize_path env path
     | _ ->*) Pident id
   in
-  let env = store_module None id path md env env in
+  let env = store_module ~check None id path md env env in
   if arg then add_functor_arg id env else env
 
 and add_modtype id info env =
@@ -1679,7 +1705,7 @@ and add_cltype id ty env =
   store_cltype None id (Pident id) ty env env
 
 let add_module ?arg id mty env =
-  add_module_declaration ?arg id (md mty) env
+  add_module_declaration ~check:false ?arg id (md mty) env
 
 let add_local_type path info env =
   { env with
@@ -1703,7 +1729,7 @@ let enter_value ?check = enter (store_value ?check)
 and enter_type = enter (store_type ~check:true)
 and enter_extension = enter (store_extension ~check:true)
 and enter_module_declaration ?arg id md env =
-  add_module_declaration ?arg id md env
+  add_module_declaration ?arg ~check:true id md env
   (* let (id, env) = enter store_module name md env in
   (id, add_functor_arg ?arg id env) *)
 and enter_modtype = enter store_modtype
@@ -1721,7 +1747,7 @@ let add_item comp env =
     Sig_value(id, decl)     -> add_value id decl env
   | Sig_type(id, decl, _)   -> add_type ~check:false id decl env
   | Sig_typext(id, ext, _)  -> add_extension ~check:false id ext env
-  | Sig_module(id, md, _)   -> add_module_declaration id md env
+  | Sig_module(id, md, _)   -> add_module_declaration ~check:false id md env
   | Sig_modtype(id, decl)   -> add_modtype id decl env
   | Sig_class(id, decl, _)  -> add_class id decl env
   | Sig_class_type(id, decl, _) -> add_cltype id decl env
@@ -1751,7 +1777,7 @@ let open_signature slot root sg env0 =
         | Sig_typext(id, ext, _) ->
             store_extension ~check:false slot (Ident.hide id) p ext env env0
         | Sig_module(id, mty, _) ->
-            store_module slot (Ident.hide id) p mty env env0
+            store_module ~check:false slot (Ident.hide id) p mty env env0
         | Sig_modtype(id, decl) ->
             store_modtype slot (Ident.hide id) p decl env env0
         | Sig_class(id, decl, _) ->
@@ -1858,7 +1884,8 @@ let save_signature_with_imports ~deprecated sg modname filename imports =
     (* Enter signature in persistent table so that imported_unit()
        will also return its crc *)
     let comps =
-      components_of_module ~deprecated empty Subst.identity
+      components_of_module ~deprecated ~loc:Location.none
+        empty Subst.identity
         (Pident(Ident.create_persistent modname)) (Mty_signature sg) in
     let ps =
       { ps_name = modname;
diff --git a/typing/env.mli b/typing/env.mli
index 31982c2bf5..f3ab7ba341 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -136,7 +136,8 @@ val add_value:
 val add_type: check:bool -> Ident.t -> type_declaration -> t -> t
 val add_extension: check:bool -> Ident.t -> extension_constructor -> t -> t
 val add_module: ?arg:bool -> Ident.t -> module_type -> t -> t
-val add_module_declaration: ?arg:bool -> Ident.t -> module_declaration -> t -> t
+val add_module_declaration: ?arg:bool -> check:bool -> Ident.t ->
+  module_declaration -> t -> t
 val add_modtype: Ident.t -> modtype_declaration -> t -> t
 val add_class: Ident.t -> class_declaration -> t -> t
 val add_cltype: Ident.t -> class_type_declaration -> t -> t
@@ -239,6 +240,7 @@ val report_error: formatter -> error -> unit
 
 
 val mark_value_used: t -> string -> value_description -> unit
+val mark_module_used: t -> string -> Location.t -> unit
 val mark_type_used: t -> string -> type_declaration -> unit
 
 type constructor_usage = Positive | Pattern | Privatize
diff --git a/typing/envaux.ml b/typing/envaux.ml
index b8268a5fd1..53f4d8877b 100644
--- a/typing/envaux.ml
+++ b/typing/envaux.ml
@@ -55,7 +55,7 @@ let rec env_from_summary sum subst =
             (Subst.extension_constructor subst desc)
             (env_from_summary s subst)
       | Env_module(s, id, desc) ->
-          Env.add_module_declaration id
+          Env.add_module_declaration ~check:false id
             (Subst.module_declaration subst desc)
             (env_from_summary s subst)
       | Env_modtype(s, id, desc) ->
@@ -79,7 +79,8 @@ let rec env_from_summary sum subst =
           Env.open_signature Asttypes.Override path'
             (extract_sig env md.md_type) env
       | Env_functor_arg(Env_module(s, id, desc), id') when Ident.same id id' ->
-          Env.add_module_declaration id (Subst.module_declaration subst desc)
+          Env.add_module_declaration ~check:false
+            id (Subst.module_declaration subst desc)
             ~arg:true (env_from_summary s subst)
       | Env_functor_arg _ -> assert false
       | Env_constraints(s, map) ->
diff --git a/typing/includemod.ml b/typing/includemod.ml
index 7b414ba5ed..a28f163588 100644
--- a/typing/includemod.ml
+++ b/typing/includemod.ml
@@ -389,6 +389,7 @@ and signature_components old_env env cxt subst paired =
       (pos, Tcoerce_none) :: comps_rec rem
   | (Sig_module(id1, mty1, _), Sig_module(_id2, mty2, _), pos) :: rem ->
       let p1 = Pident id1 in
+      Env.mark_module_used env (Ident.name id1) mty1.md_loc;
       let cc =
         modtypes env (Module id1::cxt) subst
           (Mtype.strengthen (Env.add_functor_arg id1 env) mty1.md_type p1)
diff --git a/typing/mtype.ml b/typing/mtype.ml
index 386815a325..72df0fd384 100644
--- a/typing/mtype.ml
+++ b/typing/mtype.ml
@@ -78,7 +78,8 @@ and strengthen_sig env sg p pos =
           {md with md_type = Mty_alias (Pdot(p, Ident.name id, pos))}
       in
       Sig_module(id, str, rs)
-      :: strengthen_sig (Env.add_module_declaration id md env) rem p (pos+1)
+      :: strengthen_sig
+        (Env.add_module_declaration ~check:false id md env) rem p (pos+1)
       (* Need to add the module in case it defines manifest module types *)
   | Sig_modtype(id, decl) :: rem ->
       let newdecl =
@@ -218,7 +219,8 @@ and type_paths_sig env p pos sg =
       Pdot(p, Ident.name id, nopos) :: type_paths_sig env p pos rem
   | Sig_module(id, md, _) :: rem ->
       type_paths env (Pdot(p, Ident.name id, pos)) md.md_type @
-      type_paths_sig (Env.add_module_declaration id md env) p (pos+1) rem
+      type_paths_sig (Env.add_module_declaration ~check:false id md env)
+        p (pos+1) rem
   | Sig_modtype(id, decl) :: rem ->
       type_paths_sig (Env.add_modtype id decl env) p pos rem
   | (Sig_typext _ | Sig_class _) :: rem ->
@@ -243,7 +245,8 @@ and no_code_needed_sig env sg =
       end
   | Sig_module(id, md, _) :: rem ->
       no_code_needed env md.md_type &&
-      no_code_needed_sig (Env.add_module_declaration id md env) rem
+      no_code_needed_sig
+        (Env.add_module_declaration ~check:false id md env) rem
   | (Sig_type _ | Sig_modtype _ | Sig_class_type _) :: rem ->
       no_code_needed_sig env rem
   | (Sig_typext _ | Sig_class _) :: _ ->
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 44e653ff26..c86e7930ac 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -388,7 +388,8 @@ and approx_sig env ssg =
           in
           let newenv =
             List.fold_left
-              (fun env (id, md) -> Env.add_module_declaration id md env)
+              (fun env (id, md) -> Env.add_module_declaration ~check:false
+                  id md env)
               env decls in
           map_rec (fun rs (id, md) -> Sig_module(id, md, rs)) decls
                   (approx_sig newenv srem)
@@ -1352,7 +1353,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
                    md_loc = md.md_loc;
                  }
                in
-               Env.add_module_declaration md.md_id mdecl env
+               Env.add_module_declaration ~check:true md.md_id mdecl env
             )
             env decls
         in