[project @ 2000-07-06 16:31:45 by simonpj]

* Improve the warning "M is imported but nothing from it is used"
  In particular, don't warn if some instances from it are imported.

  It's pretty much impossible to do the Right Thing always.
  A comment in Rename.lhs says
	-- NOTE: Consider
	--	      module This
	--		import M ()
	--
	--	 The import M() is not *necessarily* redundant, even if
	-- 	 we suck in no instance decls from M (e.g. it contains
	--	 no instance decls, or This contains no code).  It may be
	--	 that we import M solely to ensure that M's orphan instance
	--	 decls (or those in its imports) are visible to people who
	--	 import This.  Sigh.
	--	 There's really no good way to detect this, so the error message
	--	 in RnEnv.warnUnusedModules is weakened instead

* Minor comment changes to RnIfaces.lhs

* Use NameEnv instead of UFM in TcEnv (tidy up only)

ghc/compiler/rename/Rename.lhs

@@ -26,7 +26,8 @@ import RnIfaces		( getImportedInstDecls, importDecl, mkImportExportInfo, getInte
 			  getImportedRules, loadHomeInterface, getSlurped, removeContext,
 			  loadBuiltinRules, getDeferredDecls, ImportDeclResult(..)
 			)
-import RnEnv		( availName, availsToNameSet, unitAvailEnv, availEnvElts, plusAvailEnv, 
+import RnEnv		( availName, availsToNameSet, 
+			  emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, 
 			  warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules,
 			  lookupImplicitOccsRn, pprAvail, unknownNameErr,
 			  FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs, addOneFV
@@ -54,7 +55,9 @@ import Type		( namesOfType, funTyCon )
 import ErrUtils		( printErrorsAndWarnings, dumpIfSet, ghcExit )
 import BasicTypes	( Version, initialVersion )
 import Bag		( isEmptyBag, bagToList )
-import FiniteMap	( FiniteMap, eltsFM, fmToList, emptyFM, lookupFM, addToFM_C )
+import FiniteMap	( FiniteMap, eltsFM, fmToList, emptyFM, lookupFM, 
+			  addToFM_C, elemFM, addToFM
+			)
 import UniqSupply	( UniqSupply )
 import UniqFM		( lookupUFM )
 import SrcLoc		( noSrcLoc )
@@ -192,7 +195,8 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec l
 	-- REPORT UNUSED NAMES, AND DEBUG DUMP 
     reportUnusedNames mod_name direct_import_mods
 		      gbl_env global_avail_env
-		      export_avails source_fvs		`thenRn_`
+		      export_avails source_fvs
+		      rn_imp_decls			`thenRn_`
 
     returnRn (Just result, dump_action) }
   where
@@ -654,10 +658,12 @@ rnDeprecs gbl_env mod_deprec decls
 \begin{code}
 reportUnusedNames :: ModuleName -> [ModuleName] 
 		  -> GlobalRdrEnv -> AvailEnv
-		  -> Avails -> NameSet -> RnMG ()
+		  -> Avails -> NameSet -> [RenamedHsDecl] 
+		  -> RnMG ()
 reportUnusedNames mod_name direct_import_mods 
 		  gbl_env avail_env 
 		  export_avails mentioned_names
+		  imported_decls
   = let
 	used_names = mentioned_names `unionNameSets` availsToNameSet export_avails
 
@@ -682,7 +688,8 @@ reportUnusedNames mod_name direct_import_mods
 			    = case lookupNameEnv avail_env sub_name of
 				Just avail -> avail
 				Nothing -> WARN( isUserImportedName sub_name,
-						 text "reportUnusedName: not in avail_env" <+> ppr sub_name )
+						 text "reportUnusedName: not in avail_env" <+> 
+							ppr sub_name )
 					   Avail sub_name
 		      
 		    , case parent_avail of { AvailTC _ _ -> True; other -> False }
@@ -702,12 +709,35 @@ reportUnusedNames mod_name direct_import_mods
                                    not (isLocallyDefined n),
                                    Just txt <- [lookupNameEnv deprec_env n] ]
 
+	-- inst_mods are directly-imported modules that 
+	--	contain instance decl(s) that the renamer decided to suck in
+	-- It's not necessarily redundant to import such modules.
+	-- NOTE: import M () is not necessarily redundant, even if
+	-- 	 we suck in no instance decls from M (e.g. it contains 
+	--	 no instance decls).  It may be that we import M solely to
+	--	 ensure that M's orphan instance decls (or those in its imports)
+	--	 are visible to people who import this module.  Sigh. There's
+	-- 	 really no good way to detect this, so the error message is weakened
+	inst_mods = [m | InstD (InstDecl _ _ _ dfun _) <- imported_decls,
+			 let m = moduleName (nameModule dfun),
+			 m `elem` direct_import_mods
+		    ]
+
 	minimal_imports :: FiniteMap ModuleName AvailEnv
-	minimal_imports = foldNameSet add emptyFM really_used_names
-	add n acc = case maybeUserImportedFrom n of
-			Nothing -> acc
-			Just m  -> addToFM_C plusAvailEnv acc (moduleName m)
-					     (unitAvailEnv (mk_avail n))
+	minimal_imports0 = emptyFM
+	minimal_imports1 = foldNameSet add_name minimal_imports0 really_used_names
+	minimal_imports  = foldr   add_inst_mod minimal_imports1 inst_mods
+	
+	add_name n acc = case maybeUserImportedFrom n of
+			   Nothing -> acc
+			   Just m  -> addToFM_C plusAvailEnv acc (moduleName m)
+					        (unitAvailEnv (mk_avail n))
+	add_inst_mod m acc 
+	  | m `elemFM` acc = acc	-- We import something already
+	  | otherwise	   = addToFM acc m emptyAvailEnv
+		-- Add an empty collection of imports for a module
+		-- from which we have sucked only instance decls
+
 	mk_avail n = case lookupNameEnv avail_env n of
 			Just (AvailTC m _) | n==m      -> AvailTC n [n]
 					   | otherwise -> AvailTC m [n,m]

ghc/compiler/rename/RnEnv.lhs

@@ -763,8 +763,10 @@ warnUnusedModules mods
   | not opt_WarnUnusedImports = returnRn ()
   | otherwise 		      = mapRn_ (addWarnRn . unused_mod) mods
   where
-    unused_mod m = ptext SLIT("Module") <+> quotes (pprModuleName m) <+> 
-		   text "is imported, but nothing from it is used"
+    unused_mod m = vcat [ptext SLIT("Module") <+> quotes (pprModuleName m) <+> 
+			   text "is imported, but nothing from it is used",
+			 parens (ptext SLIT("except perhaps to re-export instances visible in") <+>
+				   quotes (pprModuleName m))]
 
 warnUnusedLocalBinds, warnUnusedImports, warnUnusedMatches :: [Name] -> RnM d ()
 warnUnusedImports names

ghc/compiler/rename/RnIfaces.lhs

@@ -364,9 +364,9 @@ loadFixDecl mod_name sig@(FixitySig rdr_name fixity loc)
 -----------------------------------------------------
 
 loadInstDecl :: Module
-	     -> Bag GatedDecl
+	     -> IfaceInsts
 	     -> RdrNameInstDecl
-	     -> RnM d (Bag GatedDecl)
+	     -> RnM d IfaceInsts
 loadInstDecl mod insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc)
   = 
 	-- Find out what type constructors and classes are "gates" for the

ghc/compiler/rename/RnMonad.lhs

@@ -314,21 +314,19 @@ data Ifaces = Ifaces {
 		-- This is used to generate the "usage" information for this module.
 		-- Subset of the previous field.
 
-		iInsts :: Bag GatedDecl,
+		iInsts :: IfaceInsts,
 		-- The as-yet un-slurped instance decls; this bag is depleted when we
 		-- slurp an instance decl so that we don't slurp the same one twice.
 		-- Each is 'gated' by the names that must be available before
 		-- this instance decl is needed.
 
 		iRules :: IfaceRules,
-		-- Similar to instance decls, except that we track the version number of the
-		-- rules we import from each module
-		-- [We keep just one rule-version number for each module]
-		-- The Bool is True if we import any rules at all from that module
+		-- Similar to instance decls, only for rules
 
 		iDeprecs :: DeprecationEnv
 	}
 
+type IfaceInsts = Bag GatedDecl
 type IfaceRules = Bag GatedDecl
 
 type GatedDecl = (NameSet, (Module, RdrNameHsDecl))

ghc/compiler/typecheck/TcEnv.lhs

@@ -61,7 +61,9 @@ import BasicTypes	( Arity )
 import IdInfo		( vanillaIdInfo )
 import Name		( Name, OccName, nameOccName, getSrcLoc,
 			  maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
-			  NamedThing(..)
+			  NamedThing(..), 
+			  NameEnv, emptyNameEnv, addToNameEnv, 
+				   extendNameEnv, lookupNameEnv, nameEnvElts
 			)
 import Unique		( pprUnique10, Unique, Uniquable(..) )
 import FiniteMap	( lookupFM, addToFM )
@@ -147,14 +149,12 @@ data TcEnv = TcEnv
 					-- ...why mutable? see notes with tcGetGlobalTyVars
 					-- Includes the in-scope tyvars
 
-type NameEnv val = UniqFM val		-- Keyed by Names
-
 type UsageEnv   = NameEnv UVar
 type TypeEnv	= NameEnv (TcKind, TcTyThing)
 type ValueEnv	= NameEnv Id	
 
 valueEnvIds :: ValueEnv -> [Id]
-valueEnvIds ve = eltsUFM ve
+valueEnvIds ve = nameEnvElts ve
 
 data TcTyThing = ATyVar TcTyVar		-- Mutable only so that the kind can be mutable
 					-- if the kind is mutable, the tyvar must be so that
@@ -165,11 +165,11 @@ data TcTyThing = ATyVar TcTyVar		-- Mutable only so that the kind can be mutable
 
 
 initEnv :: TcRef TcTyVarSet -> TcEnv
-initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM (emptyVarSet, mut)
+initEnv mut = TcEnv emptyNameEnv emptyNameEnv emptyNameEnv (emptyVarSet, mut)
 
-getEnvClasses (TcEnv _ te _ _) = [cl | (_, AClass cl _) <- eltsUFM te]
+getEnvClasses (TcEnv _ te _ _) = [cl | (_, AClass cl _) <- nameEnvElts te]
 
-getEnvTyCons  (TcEnv _ te _ _) = catMaybes (map get_tc (eltsUFM te))
+getEnvTyCons  (TcEnv _ te _ _) = catMaybes (map get_tc (nameEnvElts te))
     where
       get_tc (_, ADataTyCon tc)  = Just tc
       get_tc (_, ASynTyCon tc _) = Just tc
@@ -193,7 +193,7 @@ Extending the usage environment.
 tcExtendUVarEnv :: Name -> UVar -> TcM s r -> TcM s r
 tcExtendUVarEnv uv_name uv scope
   = tcGetEnv                                                 `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
-    tcSetEnv (TcEnv (addToUFM ue uv_name uv) te ve gtvs) scope
+    tcSetEnv (TcEnv (addToNameEnv ue uv_name uv) te ve gtvs) scope
 \end{code}
 
 Looking up in the environments.
@@ -202,7 +202,7 @@ Looking up in the environments.
 tcLookupUVar :: Name -> NF_TcM s UVar
 tcLookupUVar uv_name
   = tcGetEnv	`thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
-    case lookupUFM ue uv_name of
+    case lookupNameEnv ue uv_name of
       Just uv -> returnNF_Tc uv
       Nothing -> failWithTc (uvNameOutOfScope uv_name)
 \end{code}	
@@ -221,7 +221,7 @@ tcExtendTyVarEnv tyvars scope
 	extend_list = [ (getName tv, (kindToTcKind (tyVarKind tv), ATyVar tv))
 		      | tv <- tyvars
 		      ]
- 	te'           = addListToUFM te extend_list
+ 	te'           = extendNameEnv te extend_list
 	new_tv_set    = mkVarSet tyvars
 	in_scope_tvs' = in_scope_tvs `unionVarSet` new_tv_set
     in
@@ -244,7 +244,7 @@ tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM s r -> TcM s r
 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
   = tcGetEnv					`thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
     let
-	te' = addListToUFM te stuff
+	te' = extendNameEnv te stuff
     in
     tcSetEnv (TcEnv ue te' ve gtvs) thing_inside
   where
@@ -297,7 +297,7 @@ tcExtendTypeEnv bindings scope
 	-- Not for tyvars; use tcExtendTyVarEnv
     tcGetEnv					`thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
     let
-	te' = addListToUFM te bindings
+	te' = extendNameEnv te bindings
     in
     tcSetEnv (TcEnv ue te' ve gtvs) scope
 \end{code}
@@ -309,7 +309,7 @@ Looking up in the environments.
 tcLookupTy :: Name ->  NF_TcM s (TcKind, TcTyThing)
 tcLookupTy name
   = tcGetEnv	`thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
-    case lookupUFM te name of {
+    case lookupNameEnv te name of {
 	Just thing -> returnNF_Tc thing ;
  	Nothing    -> 
 
@@ -368,7 +368,7 @@ tcExtendLocalValEnv names_w_ids scope
   = tcGetEnv		`thenNF_Tc` \ (TcEnv ue te ve (in_scope_tvs,gtvs)) ->
     tcReadMutVar gtvs	`thenNF_Tc` \ global_tvs ->
     let
-	ve'		    = addListToUFM ve names_w_ids
+	ve'		    = extendNameEnv ve names_w_ids
 	extra_global_tyvars = tyVarsOfTypes (map (idType . snd) names_w_ids)
     in
     tc_extend_gtvs gtvs extra_global_tyvars	`thenNF_Tc` \ gtvs' ->
@@ -391,7 +391,7 @@ tcLookupValueMaybe name
   = case maybeWiredInIdName name of
 	Just id -> returnNF_Tc (Just id)
 	Nothing -> tcGetEnv 		`thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
-		   returnNF_Tc (lookupUFM ve name)
+		   returnNF_Tc (lookupNameEnv ve name)
 
 tcLookupValueByKey :: Unique -> NF_TcM s Id	-- Panics if not found
 tcLookupValueByKey key
@@ -424,7 +424,7 @@ explicitLookupValue :: ValueEnv -> Name -> Maybe Id
 explicitLookupValue ve name
   = case maybeWiredInIdName name of
 	Just id -> Just id
-	Nothing -> lookupUFM ve name
+	Nothing -> lookupNameEnv ve name
 
 	-- Extract the IdInfo from an IfaceSig imported from an interface file
 tcAddImportedIdInfo :: ValueEnv -> Id -> Id