[project @ 1999-06-28 16:33:17 by simonpj]

Some renamer fixes

* Correct the defn of Rename.isOrphanRule (caused a Sergey bug)

* Tidy up the Rename.implicitFVs stuff

ghc/compiler/prelude/PrelInfo.lhs

@@ -14,14 +14,14 @@ module PrelInfo (
 			-- it is here, unique and all.  Includes all the 
 
 	derivingOccurrences, 	-- For a given class C, this tells what other 
-				-- things are needed as a result of a 
+	derivableClassKeys,	-- things are needed as a result of a 
 				-- deriving(C) clause
 
 
 	-- Random other things
 	main_NAME, ioTyCon_NAME,
 	deRefStablePtr_NAME, makeStablePtr_NAME,
-	bindIO_NAME, 
+	bindIO_NAME,
 
 	maybeCharLikeCon, maybeIntLikeCon,
 	needsDataDeclCtxtClassKeys, cCallishClassKeys, cCallishTyKeys, 

ghc/compiler/rename/Rename.lhs

@@ -22,16 +22,17 @@ import RnMonad
 import RnNames		( getGlobalNames )
 import RnSource		( rnSourceDecls, rnDecl )
 import RnIfaces		( getImportedInstDecls, importDecl, getImportVersions,
-			  getImportedRules, loadHomeInterface, getSlurped
+			  getImportedRules, loadHomeInterface, getSlurped, removeContext
 			)
 import RnEnv		( availName, availNames, availsToNameSet, 
-			  warnUnusedTopNames, mapFvRn,
+			  warnUnusedTopNames, mapFvRn, lookupImplicitOccRn,
 			  FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs
 			)
 import Module           ( Module, ModuleName, pprModule, mkSearchPath, mkThisModule )
 import Name		( Name, isLocallyDefined,
 			  NamedThing(..), ImportReason(..), Provenance(..),
-			  pprOccName, getNameProvenance, 
+			  pprOccName, nameOccName,
+			  getNameProvenance, 
 			  maybeWiredInTyConName, maybeWiredInIdName, isWiredInName
 			)
 import Id		( idType )
@@ -41,7 +42,7 @@ import RdrName		( RdrName )
 import NameSet
 import PrelMods		( mAIN_Name, pREL_MAIN_Name )
 import TysWiredIn	( unitTyCon, intTyCon, doubleTyCon, boolTyCon )
-import PrelInfo		( ioTyCon_NAME, thinAirIdNames )
+import PrelInfo		( ioTyCon_NAME, numClass_RDR, thinAirIdNames, derivingOccurrences )
 import Type		( namesOfType, funTyCon )
 import ErrUtils		( pprBagOfErrors, pprBagOfWarnings,
 			  doIfSet, dumpIfSet, ghcExit
@@ -50,6 +51,7 @@ import BasicTypes	( NewOrData(..) )
 import Bag		( isEmptyBag, bagToList )
 import FiniteMap	( fmToList, delListFromFM, addToFM, sizeFM, eltsFM )
 import UniqSupply	( UniqSupply )
+import UniqFM		( lookupUFM )
 import Util		( equivClasses )
 import Maybes		( maybeToBool )
 import Outputable
@@ -118,8 +120,9 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls loc)
     )					`thenRn` \ (rn_local_decls, source_fvs) ->
 
 	-- SLURP IN ALL THE NEEDED DECLARATIONS
+    implicitFVs mod_name rn_local_decls 	`thenRn` \ implicit_fvs -> 
     let
-	real_source_fvs = implicitFVs mod_name `plusFV` source_fvs
+	real_source_fvs = implicit_fvs `plusFV` source_fvs
 		-- It's important to do the "plus" this way round, so that
 		-- when compiling the prelude, locally-defined (), Bool, etc
 		-- override the implicit ones. 
@@ -168,10 +171,13 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls loc)
 mentioned explicitly, but which might be needed by the type checker.
 
 \begin{code}
-implicitFVs mod_name
-  = implicit_main		`plusFV` 
-    mkNameSet default_tys	`plusFV`
-    mkNameSet thinAirIdNames
+implicitFVs mod_name decls
+  = mapRn lookupImplicitOccRn implicit_occs	`thenRn` \ implicit_names ->
+    returnRn (implicit_main		`plusFV` 
+	      mkNameSet default_tys	`plusFV`
+	      mkNameSet thinAirIdNames	`plusFV`
+	      mkNameSet implicit_names)
+    
   where
 	-- Add occurrences for Int, Double, and (), because they
 	-- are the types to which ambigious type variables may be defaulted by
@@ -187,11 +193,30 @@ implicitFVs mod_name
     implicit_main |  mod_name == mAIN_Name
 		  || mod_name == pREL_MAIN_Name = unitFV ioTyCon_NAME
 		  |  otherwise 		        = emptyFVs
+
+	-- Now add extra "occurrences" for things that
+	-- the deriving mechanism, or defaulting, will later need in order to
+	-- generate code
+    implicit_occs = foldr ((++) . get) [] decls
+
+    get (DefD _) = [numClass_RDR]
+    get (TyClD (TyData _ _ _ _ _ (Just deriv_classes) _ _))
+       = concat (map get_deriv deriv_classes)
+    get other = []
+
+    get_deriv cls = case lookupUFM derivingOccurrences cls of
+			Nothing   -> []
+			Just occs -> occs
 \end{code}
 
 \begin{code}
 isOrphanDecl (InstD (InstDecl inst_ty _ _ _ _))
-  = not (foldNameSet ((||) . isLocallyDefined) False (extractHsTyNames inst_ty))
+  = not (foldNameSet ((||) . isLocallyDefined) False (extractHsTyNames (removeContext inst_ty)))
+	-- The 'removeContext' is because of
+	--	instance Foo a => Baz T where ...
+	-- The decl is an orphan if Baz and T are both not locally defined,
+	--	even if Foo *is* locally defined
+
 isOrphanDecl (RuleD (RuleDecl _ _ _ lhs _ _))
   = check lhs
   where
@@ -462,10 +487,6 @@ getInstDeclGates other				    = emptyFVs
 
 \begin{code}
 reportUnusedNames gbl_env avail_env (ExportEnv export_avails _) mentioned_names
-  | not (opt_WarnUnusedBinds || opt_WarnUnusedImports)
-  = returnRn ()
-
-  | otherwise
   = let
 	used_names = mentioned_names `unionNameSets` availsToNameSet export_avails
 
@@ -487,8 +508,7 @@ reportUnusedNames gbl_env avail_env (ExportEnv export_avails _) mentioned_names
 	-- Filter out the ones only defined implicitly
 	bad_guys = filter reportableUnusedName defined_but_not_used
     in
-    warnUnusedTopNames bad_guys	`thenRn_`
-    returnRn ()
+    warnUnusedTopNames bad_guys
 
 reportableUnusedName :: Name -> Bool
 reportableUnusedName name
@@ -500,7 +520,7 @@ reportableUnusedName name
  	-- Report unused explicit imports
     explicitlyImported other			             = False
 	-- Don't report others
-   
+
 rnStats :: [RenamedHsDecl] -> RnMG ()
 rnStats imp_decls
         | opt_D_dump_rn_trace || 

ghc/compiler/rename/RnEnv.lhs

@@ -29,7 +29,7 @@ import Name		( Name, Provenance(..), ExportFlag(..), NamedThing(..),
 			)
 import NameSet
 import OccName		( OccName,
-			  mkDFunOcc, 
+			  mkDFunOcc, occNameUserString,
 			  occNameFlavour
 			)
 import TysWiredIn	( tupleTyCon, unboxedTupleTyCon, listTyCon )
@@ -453,7 +453,7 @@ whether there are any instance decls in this module are ``special''.
 The name cache should have the correct provenance, though.
 
 \begin{code}
-lookupImplicitOccRn :: RdrName -> RnMS Name 
+lookupImplicitOccRn :: RdrName -> RnM d Name 
 lookupImplicitOccRn rdr_name = mkImportedGlobalFromRdrName rdr_name
 \end{code}
 
@@ -725,32 +725,28 @@ warnUnusedBinds warn_when_local names
 
 warnUnusedGroup :: (Bool -> Bool) -> [Name] -> RnM d ()
 warnUnusedGroup emit_warning names
+  | null filtered_names         = returnRn ()
   | not (emit_warning is_local) = returnRn ()
   | otherwise
-  = case filter isReportable names of
-      []       -> returnRn ()
-      repnames -> warn repnames
+  = pushSrcLocRn def_loc	$
+    addWarnRn			$
+    sep [msg <> colon, nest 4 (fsep (punctuate comma (map ppr filtered_names)))]
   where
-  warn repnames = pushSrcLocRn def_loc	$
-                  addWarnRn		$
-                  sep [msg <> colon, nest 4 (fsep (punctuate comma (map ppr repnames)))]
-
-  name1 = head names
-
-  (is_local, def_loc, msg)
-	   = case getNameProvenance name1 of
+    filtered_names = filter reportable names
+    name1 	   = head filtered_names
+    (is_local, def_loc, msg)
+	= case getNameProvenance name1 of
 		LocalDef loc _ 			     -> (True, loc, text "Defined but not used")
 		NonLocalDef (UserImport mod loc _) _ ->
 		 (True, loc, text "Imported from" <+> quotes (ppr mod) <+> 
 			 			      text "but not used")
 		other -> (False, getSrcLoc name1, text "Strangely defined but not used")
 
-  isReportable = not . startsWithUnderscore . occNameUserString  . nameOccName
-    -- Haskell 98 encourages compilers to suppress warnings about
-    -- unused names in a pattern if they start with "_".
-  startsWithUnderscore ('_' : _) = True
-    -- Suppress warnings for names starting with an underscore
-  startsWithUnderscore other     = False
+    reportable name = case occNameUserString (nameOccName name) of
+			('_' : _) -> False
+			_other	  -> True
+	-- Haskell 98 encourages compilers to suppress warnings about
+	-- unused names in a pattern if they start with "_".
 \end{code}
 
 \begin{code}

ghc/compiler/rename/RnIfaces.lhs

@@ -13,7 +13,8 @@ module RnIfaces (
 
 	checkUpToDate,
 
-	getDeclBinders, getDeclSysBinders
+	getDeclBinders, getDeclSysBinders,
+	removeContext	 	-- removeContext probably belongs somewhere else
     ) where
 
 #include "HsVersions.h"

ghc/compiler/rename/RnSource.lhs

@@ -40,15 +40,15 @@ import NameSet
 import OccName		( mkDefaultMethodOcc )
 import BasicTypes	( TopLevelFlag(..) )
 import FiniteMap	( elemFM )
-import PrelInfo		( derivingOccurrences, numClass_RDR, 
-			  deRefStablePtr_NAME, makeStablePtr_NAME,
-			  bindIO_NAME
+import PrelInfo		( derivableClassKeys,
+			  deRefStablePtr_NAME, makeStablePtr_NAME, bindIO_NAME
 			)
 import Bag		( bagToList )
 import List		( partition, nub )
 import Outputable
 import SrcLoc		( SrcLoc )
 import CmdLineOpts	( opt_WarnUnusedMatches )	-- Warn of unused for-all'd tyvars
+import Unique		( Uniquable(..) )
 import UniqFM		( lookupUFM )
 import Maybes		( maybeToBool, catMaybes )
 import Util
@@ -348,8 +348,7 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags dfun_rdr_name src_loc))
 rnDecl (DefD (DefaultDecl tys src_loc))
   = pushSrcLocRn src_loc $
     rnHsTypes doc_str tys		`thenRn` \ (tys', fvs) ->
-    lookupImplicitOccRn numClass_RDR	`thenRn` \ num ->
-    returnRn (DefD (DefaultDecl tys' src_loc), fvs `addOneFV` num)
+    returnRn (DefD (DefaultDecl tys' src_loc), fvs)
   where
     doc_str = text "a `default' declaration"
 \end{code}
@@ -437,22 +436,14 @@ rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name], FreeVars)
 rnDerivs Nothing -- derivs not specified
   = returnRn (Nothing, emptyFVs)
 
-rnDerivs (Just ds)
-  = mapFvRn rn_deriv ds		`thenRn` \ (derivs, fvs) ->
-    returnRn (Just derivs, fvs)
+rnDerivs (Just clss)
+  = mapRn do_one clss	`thenRn` \ clss' ->
+    returnRn (Just clss', mkNameSet clss')
   where
-    rn_deriv clas
-      = lookupOccRn clas	    `thenRn` \ clas_name ->
-
-		-- Now add extra "occurrences" for things that
-		-- the deriving mechanism will later need in order to
-		-- generate code for this class.
-	case lookupUFM derivingOccurrences clas_name of
-		Nothing -> addErrRn (derivingNonStdClassErr clas_name)	`thenRn_`
-			   returnRn (clas_name, unitFV clas_name)
-
-		Just occs -> mapRn lookupImplicitOccRn occs	`thenRn` \ names ->
-			     returnRn (clas_name, mkNameSet (clas_name : names))
+    do_one cls = lookupOccRn cls	`thenRn` \ clas_name ->
+		 checkRn (getUnique clas_name `elem` derivableClassKeys)
+			 (derivingNonStdClassErr clas_name)	`thenRn_`
+		 returnRn clas_name
 \end{code}
 
 \begin{code}