[project @ 2000-10-24 10:36:08 by simonpj]

Wibbles

ghc/compiler/rename/Rename.lhs

@@ -50,8 +50,8 @@ import PrelNames	( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name,
 			)
 import PrelInfo		( fractionalClassKeys, derivingOccurrences, wiredInThingEnv )
 import Type		( namesOfType, funTyCon )
-import ErrUtils		( printErrorsAndWarnings, dumpIfSet )
-import Bag		( isEmptyBag, bagToList )
+import ErrUtils		( dumpIfSet )
+import Bag		( bagToList )
 import FiniteMap	( FiniteMap, eltsFM, fmToList, emptyFM, lookupFM, 
 			  addToFM_C, elemFM, addToFM
 			)
@@ -77,21 +77,17 @@ renameModule :: DynFlags -> Finder
 	     -> Module -> RdrNameHsModule 
 	     -> IO (PersistentCompilerState, Maybe (ModIface, [RenamedHsDecl]))
 
-renameModule dflags finder hit hst old_pcs this_module 
-	     this_mod@(HsModule _ _ _ _ _ _ loc)
+renameModule dflags finder hit hst old_pcs this_module rdr_module
   = 	-- Initialise the renamer monad
     do {
-	((maybe_rn_stuff, dump_action), (rn_warns_bag, rn_errs_bag), new_pcs) 
-	   <- initRn dflags finder hit hst old_pcs this_module loc (rename this_module this_mod) ;
-
-	-- Check for warnings
-	printErrorsAndWarnings (rn_warns_bag, rn_errs_bag) ;
+	(new_pcs, errors_found, (maybe_rn_stuff, dump_action)) 
+	   <- initRn dflags finder hit hst old_pcs this_module (rename this_module rdr_module) ;
 
 	-- Dump any debugging output
 	dump_action ;
 
 	-- Return results
-	if not (isEmptyBag rn_errs_bag) then
+	if errors_found then
 	    return (old_pcs, Nothing)
         else
 	    return (new_pcs, maybe_rn_stuff)

ghc/compiler/rename/RnIfaces.lhs

@@ -10,13 +10,15 @@ module RnIfaces
 	getImportedInstDecls, getImportedRules,
 	lookupFixityRn, 
 	importDecl, ImportDeclResult(..), recordLocalSlurps, 
-	mkImportInfo, getSlurped
+	mkImportInfo, getSlurped,
+
+	recompileRequired
        )
 where
 
 #include "HsVersions.h"
 
-import CmdLineOpts	( opt_NoPruneDecls, opt_NoPruneTyDecls, opt_IgnoreIfacePragmas )
+import CmdLineOpts	( DynFlags, opt_NoPruneDecls, opt_NoPruneTyDecls, opt_IgnoreIfacePragmas )
 import HscTypes
 import HsSyn		( HsDecl(..), InstDecl(..),  HsType(..) )
 import HsImpExp		( ImportDecl(..) )
@@ -300,7 +302,7 @@ mkImportInfo this_mod imports
 
 	     where
 		go_for_it exports = (mod_name, has_orphans, is_boot, exports) : so_far
-	        mod_iface 	  = lookupIface hit pit mod_name
+	        mod_iface 	  = lookupTableByModName hit pit mod_name `orElse` panic "mkImportInfo"
 		mod		  = mi_module mod_iface
 	        is_lib_module     = not (isModuleInThisPackage mod)
 	        version_info      = mi_version mod_iface
@@ -495,14 +497,27 @@ that we know just what instances to bring into scope.
 %*							*
 %********************************************************
 
+@recompileRequired@ is called from the HscMain.   It checks whether
+a recompilation is required.  It needs access to the persistent state,
+finder, etc, because it may have to load lots of interface files to
+check their versions.
+
 \begin{code}
 type RecompileRequired = Bool
 upToDate  = False	-- Recompile not required
 outOfDate = True	-- Recompile required
 
-recompileRequired :: Module -> Bool -> Maybe ModIface -> RnMG RecompileRequired
-recompileRequired mod source_unchanged maybe_iface
-  = traceRn (text "Considering whether compilation is required for" <+> ppr mod <> colon)	`thenRn_`
+recompileRequired :: DynFlags -> Finder
+		  -> HomeIfaceTable -> HomeSymbolTable
+		  -> PersistentCompilerState
+		  -> Module 
+		  -> Bool 		-- Source unchanged
+		  -> Maybe ModIface 	-- Old interface, if any
+		  -> IO (PersistentCompilerState, Bool, RecompileRequired)
+				-- True <=> errors happened
+recompileRequired dflags finder hit hst pcs mod source_unchanged maybe_iface
+  = initRn dflags finder hit hst pcs mod $
+    traceRn (text "Considering whether compilation is required for" <+> ppr mod <> colon)	`thenRn_`
 
 	-- CHECK WHETHER THE SOURCE HAS CHANGED
     if not source_unchanged then
@@ -516,8 +531,7 @@ recompileRequired mod source_unchanged maybe_iface
 		   returnRn outOfDate ;
 
 	Just iface  ->    	-- Source code unchanged and no errors yet... carry on 
-			getHomeIfaceTableRn					`thenRn` \ hit ->
-			checkList [checkModUsage hit u | u <- mi_usages iface]
+			checkList [checkModUsage u | u <- mi_usages iface]
 
 checkList :: [RnMG RecompileRequired] -> RnMG RecompileRequired
 checkList []		 = returnRn upToDate
@@ -529,12 +543,12 @@ checkList (check:checks) = check	`thenRn` \ recompile ->
 \end{code}
 	
 \begin{code}
-checkModUsage :: HomeIfaceTable -> ImportVersion Name -> RnMG RecompileRequired
+checkModUsage :: ImportVersion Name -> RnMG RecompileRequired
 -- Given the usage information extracted from the old
 -- M.hi file for the module being compiled, figure out
 -- whether M needs to be recompiled.
 
-checkModUsage hit (mod_name, _, _, NothingAtAll)
+checkModUsage (mod_name, _, _, NothingAtAll)
 	-- If CurrentModule.hi contains 
 	--	import Foo :: ;
 	-- then that simply records that Foo lies below CurrentModule in the
@@ -542,7 +556,7 @@ checkModUsage hit (mod_name, _, _, NothingAtAll)
 	-- In this case we don't even want to open Foo's interface.
   = up_to_date (ptext SLIT("Nothing used from:") <+> ppr mod_name)
 
-checkModUsage hit (mod_name, _, _, whats_imported)
+checkModUsage (mod_name, _, _, whats_imported)
   = tryLoadInterface doc_str mod_name ImportBySystem	`thenRn` \ (ifaces, maybe_err) ->
     case maybe_err of {
 	Just err -> out_of_date (sep [ptext SLIT("Can't find version number for module"), 
@@ -552,6 +566,8 @@ checkModUsage hit (mod_name, _, _, whats_imported)
 		-- the current module doesn't need that import and it's been deleted
 
 	Nothing -> 
+
+    getHomeIfaceTableRn					`thenRn` \ hit ->
     let
 	mod_details   = lookupTableByModName hit (iPIT ifaces) mod_name
 			`orElse` panic "checkModUsage"

ghc/compiler/rename/RnMonad.lhs

@@ -44,7 +44,7 @@ import HscTypes		( Finder,
 			  HomeSymbolTable, PackageSymbolTable,
 			  PersistentCompilerState(..), GlobalRdrEnv,
 			  HomeIfaceTable, PackageIfaceTable,
-			  RdrAvailInfo, ModIface )
+			  RdrAvailInfo )
 import BasicTypes	( Version, defaultFixity )
 import ErrUtils		( addShortErrLocLine, addShortWarnLocLine,
 			  pprBagOfErrors, ErrMsg, WarnMsg, Message
@@ -59,17 +59,18 @@ import Name		( Name, OccName, NamedThing(..), getSrcLoc,
 			  NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, 
 			  extendNameEnvList
 			)
-import Module		( Module, ModuleName, lookupModuleEnvByName )
+import Module		( Module, ModuleName )
 import NameSet		
 import CmdLineOpts	( DynFlags, DynFlag(..), dopt )
-import SrcLoc		( SrcLoc, generatedSrcLoc )
+import SrcLoc		( SrcLoc, generatedSrcLoc, noSrcLoc )
 import Unique		( Unique )
 import FiniteMap	( FiniteMap, emptyFM )
 import Bag		( Bag, emptyBag, isEmptyBag, snocBag )
 import UniqSupply
 import Outputable
 import PrelNames	( mkUnboundName )
-import Maybes		( maybeToBool, seqMaybe, orElse )
+import Maybes		( maybeToBool, seqMaybe )
+import ErrUtils		( printErrorsAndWarnings )
 
 infixr 9 `thenRn`, `thenRn_`
 \end{code}
@@ -285,28 +286,38 @@ type IsLoaded = Bool
 %************************************************************************
 
 \begin{code}
-initRn :: DynFlags 
-       -> Finder 
-       -> HomeIfaceTable
-       -> HomeSymbolTable
+initRn :: DynFlags       -> Finder 
+       -> HomeIfaceTable -> HomeSymbolTable
        -> PersistentCompilerState
-       -> Module 
-       -> SrcLoc
+       -> Module
        -> RnMG t
-       -> IO (t, (Bag WarnMsg, Bag ErrMsg), PersistentCompilerState)
+       -> IO (PersistentCompilerState, Bool, t)	
+		-- True <=> found errors
 
-initRn dflags finder hit hst pcs mod loc do_rn
+initRn dflags finder hit hst pcs mod do_rn
   = do 
 	let prs = pcs_PRS pcs
 	let pst = pcs_PST pcs
+	let ifaces = Ifaces { iPIT   = pcs_PIT pcs,
+			      iDecls = prsDecls prs,
+		  	      iInsts = prsInsts prs,
+		 	      iRules = prsRules prs,
+
+		 	      iImpModInfo = emptyFM,
+			      iSlurp      = unitNameSet (mkUnboundName dummyRdrVarName),
+				-- Pretend that the dummy unbound name has already been
+				-- slurped.  This is what's returned for an out-of-scope name,
+				-- and we don't want thereby to try to suck it in!
+			      iVSlurp = []
+		      }
         let uniqs = prsNS prs
 
 	names_var <- newIORef (uniqs, origNames (prsOrig prs), 
 				      origIParam (prsOrig prs))
 	errs_var  <- newIORef (emptyBag,emptyBag)
-	iface_var <- newIORef (initIfaces pcs)
+	iface_var <- newIORef ifaces
 	let rn_down = RnDown { rn_mod = mod,
-			       rn_loc = loc, 
+			       rn_loc = noSrcLoc, 
 	
 			       rn_finder = finder,
 			       rn_dflags = dflags,
@@ -334,34 +345,15 @@ initRn dflags finder hit hst pcs mod loc do_rn
 	let new_pcs = pcs { pcs_PIT = iPIT new_ifaces, 
 			    pcs_PRS = new_prs }
 	
-	return (res, (warns, errs), new_pcs)
+	-- Check for warnings
+	printErrorsAndWarnings (warns, errs) ;
+
+	return (new_pcs, not (isEmptyBag errs), res)
 
 is_done :: HomeSymbolTable -> PackageSymbolTable -> Name -> Bool
 -- Returns True iff the name is in either symbol table
 is_done hst pst n = maybeToBool (lookupTypeEnv pst n `seqMaybe` lookupTypeEnv hst n)
 
-lookupIface :: HomeIfaceTable -> PackageIfaceTable -> ModuleName -> ModIface
-lookupIface hit pit mod = lookupModuleEnvByName hit mod `orElse` 
-			  lookupModuleEnvByName pit mod `orElse`
-			  pprPanic "lookupIface" (ppr mod)
-
-initIfaces :: PersistentCompilerState -> Ifaces
-initIfaces (PCS { pcs_PIT = pit, pcs_PRS = prs })
-  = Ifaces { iPIT   = pit,
-	     iDecls = prsDecls prs,
-	     iInsts = prsInsts prs,
-	     iRules = prsRules prs,
-
-	     iImpModInfo = emptyFM,
-	     iSlurp      = unitNameSet (mkUnboundName dummyRdrVarName),
-			-- Pretend that the dummy unbound name has already been
-			-- slurped.  This is what's returned for an out-of-scope name,
-			-- and we don't want thereby to try to suck it in!
-	     iVSlurp = []
-      }
-
-
-initRnMS :: GlobalRdrEnv -> LocalFixityEnv -> RnMode -> RnMS r -> RnM d r
 initRnMS rn_env fixity_env mode thing_inside rn_down g_down
   = let
 	s_down = SDown { rn_genv = rn_env, rn_lenv = emptyRdrEnv, 

ghc/compiler/typecheck/TcDeriv.lhs

@@ -16,7 +16,7 @@ import RnHsSyn		( RenamedHsBinds, RenamedMonoBinds )
 import CmdLineOpts	( DynFlag(..), DynFlags )
 
 import TcMonad
-import TcEnv		( TcEnv, tcSetInstEnv, getTcGST, newDFunName )
+import TcEnv		( TcEnv, tcSetInstEnv, newDFunName )
 import TcGenDeriv	-- Deriv stuff
 import InstEnv		( InstInfo(..), InstEnv, 
 			  pprInstInfo, simpleDFunClassTyCon, extendInstEnv )
@@ -26,33 +26,29 @@ import RnBinds		( rnMethodBinds, rnTopMonoBinds )
 import RnEnv		( bindLocatedLocalsRn )
 import RnMonad		( --RnNameSupply, 
 			  renameSourceCode, thenRn, mapRn, returnRn )
-import HscTypes		( DFunId, GlobalSymbolTable, PersistentRenamerState )
+import HscTypes		( DFunId, PersistentRenamerState )
 
 import BasicTypes	( Fixity )
-import Bag		( Bag, emptyBag, unionBags, listToBag )
 import Class		( classKey, Class )
 import ErrUtils		( dumpIfSet_dyn, Message )
 import MkId		( mkDictFunId )
-import Id		( mkVanillaId, idType )
+import Id		( idType )
 import DataCon		( dataConArgTys, isNullaryDataCon, isExistentialDataCon )
 import PrelInfo		( needsDataDeclCtxtClassKeys )
 import Maybes		( maybeToBool, catMaybes )
 import Module		( Module )
-import Name		( Name, isLocallyDefined, getSrcLoc, NamedThing(..) )
+import Name		( Name, isLocallyDefined, getSrcLoc )
 import RdrName		( RdrName )
 
 import TyCon		( tyConTyVars, tyConDataCons, tyConDerivings,
 			  tyConTheta, maybeTyConSingleCon, isDataTyCon,
-			  isEnumerationTyCon, isAlgTyCon, TyCon
+			  isEnumerationTyCon, TyCon
 			)
 import Type		( TauType, PredType(..), mkTyVarTys, mkTyConApp,
-			  mkSigmaTy, splitDFunTy, mkDictTy, 
-			  isUnboxedType, splitAlgTyConApp, classesToPreds
+			  splitDFunTy, isUnboxedType
 			)
-import TysWiredIn	( voidTy )
 import Var		( TyVar )
 import PrelNames
-import Bag		( bagToList )
 import Util		( zipWithEqual, sortLt, thenCmp )
 import ListSetOps	( removeDups,  assoc )
 import Outputable

ghc/compiler/typecheck/TcInstDcls.lhs

@@ -11,11 +11,10 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2, tcAddDeclCtxt ) where
 
 import CmdLineOpts	( DynFlag(..), dopt )
 
-import HsSyn		( HsDecl(..), InstDecl(..), TyClDecl(..), InPat(..),
-			  MonoBinds(..), HsExpr(..),  HsLit(..), Sig(..), Match(..),
+import HsSyn		( HsDecl(..), InstDecl(..), TyClDecl(..), 
+			  MonoBinds(..), HsExpr(..),  HsLit(..), Sig(..), 
 			  andMonoBindList, collectMonoBinders, isClassDecl
 			)
-import HsTypes          ( HsType (..), HsTyVarBndr(..), toHsTyVar )
 import RnHsSyn		( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, RenamedMonoBinds,
 			  RenamedTyClDecl, RenamedHsType, 
 			  extractHsTyVars, maybeGenericMatch
@@ -29,25 +28,23 @@ import Inst		( InstOrigin(..),
 			  LIE, emptyLIE, plusLIE, plusLIEs )
 import TcDeriv		( tcDeriving )
 import TcEnv		( TcEnv, tcExtendGlobalValEnv, 
-			  tcExtendTyVarEnvForMeths, TyThing (..),
+			  tcExtendTyVarEnvForMeths, 
 			  tcAddImportedIdInfo, tcInstId, tcLookupClass,
 			  newDFunName, tcExtendTyVarEnv
 			)
 import InstEnv		( InstInfo(..), InstEnv, pprInstInfo, classDataCon, 
  			  simpleInstInfoTyCon, simpleInstInfoTy, isLocalInst,
 			  extendInstEnv )
-import TcMonoType	( tcTyVars, tcHsSigType, tcHsType, kcHsSigType )
+import TcMonoType	( tcTyVars, tcHsSigType, kcHsSigType )
 import TcSimplify	( tcSimplifyAndCheck )
 import TcType		( zonkTcSigTyVars )
 import HscTypes		( PersistentCompilerState(..), HomeSymbolTable, DFunId,
 			  ModDetails(..) )
 
-import Bag		( emptyBag, unitBag, unionBags, unionManyBags,
-			  foldBag, Bag, listToBag
-			)
+import Bag		( unionManyBags	)
 import Class		( Class, DefMeth(..), classBigSig )
 import Var		( idName, idType )
-import Maybes 		( maybeToBool, expectJust )
+import Maybes 		( maybeToBool )
 import MkId		( mkDictFunId )
 import Generics		( validGenericInstanceType )
 import Module		( Module, foldModuleEnv )
@@ -58,7 +55,7 @@ import PprType		( pprConstraint, pprPred )
 import TyCon		( TyCon, isSynTyCon, tyConDerivings )
 import Type		( mkTyVarTys, splitDFunTy, isTyVarTy,
 			  splitTyConApp_maybe, splitDictTy,
-			  splitAlgTyConApp_maybe, classesToPreds, classesOfPreds,
+			  splitAlgTyConApp_maybe, 
 			  unUsgTy, tyVarsOfTypes, mkClassPred, mkTyVarTy,
 			  getClassTys_maybe
 			)
@@ -66,12 +63,9 @@ import Subst		( mkTopTyVarSubst, substClasses, substTheta )
 import VarSet		( mkVarSet, varSetElems )
 import TysWiredIn	( genericTyCons, isFFIArgumentTy, isFFIResultTy )
 import PrelNames	( cCallableClassKey, cReturnableClassKey, hasKey )
-import Name             ( Name, NameEnv, extendNameEnv_C, emptyNameEnv, 
-			  plusNameEnv_C, nameEnvElts )
-import FiniteMap        ( mapFM )
+import Name             ( Name )
 import SrcLoc           ( SrcLoc )
 import VarSet           ( varSetElems )
-import UniqFM           ( mapUFM )
 import Unique		( Uniquable(..) )
 import BasicTypes	( NewOrData(..), Fixity )
 import ErrUtils		( dumpIfSet_dyn )
@@ -79,7 +73,7 @@ import ListSetOps	( Assoc, emptyAssoc, plusAssoc_C, mapAssoc,
 			  assocElts, extendAssoc_C,
 			  equivClassesByUniq, minusList
 			)
-import List             ( intersect, (\\), partition )
+import List             ( partition )
 import Outputable
 \end{code}
 

ghc/compiler/typecheck/TcModule.lhs

@@ -21,7 +21,7 @@ import TcHsSyn		( TypecheckedMonoBinds,
 			)
 
 import TcMonad
-import Inst		( emptyLIE, plusLIE )
+import Inst		( plusLIE )
 import TcBinds		( tcTopBinds )
 import TcClassDcl	( tcClassDecls2, mkImplicitClassBinds )
 import TcDefaults	( tcDefaults )
@@ -47,16 +47,13 @@ import Module           ( Module, moduleName, plusModuleEnv )
 import Name		( Name, nameOccName, isLocallyDefined, isGlobalName,
 			  toRdrName, nameEnvElts, emptyNameEnv, lookupNameEnv
 			)
-import TyCon		( TyCon, isDataTyCon, tyConName, tyConGenInfo )
+import TyCon		( tyConGenInfo, isClassTyCon )
 import OccName		( isSysOcc )
-import TyCon		( TyCon, isClassTyCon )
-import Class		( Class )
 import PrelNames	( mAIN_Name, mainName )
-import UniqSupply       ( UniqSupply )
-import Maybes		( maybeToBool, thenMaybe )
+import Maybes		( thenMaybe )
 import Util
 import BasicTypes       ( EP(..), Fixity )
-import Bag		( Bag, isEmptyBag )
+import Bag		( isEmptyBag )
 import Outputable
 import HscTypes		( PersistentCompilerState(..), HomeSymbolTable, HomeIfaceTable,
 			  PackageSymbolTable, PackageIfaceTable, DFunId, ModIface(..),
@@ -135,7 +132,6 @@ tcModule pcs hst get_fixity this_mod decls unf_env
     let
         classes       = tcEnvClasses env
         tycons        = tcEnvTyCons env	-- INCLUDES tycons derived from classes
-        local_classes = filter isLocallyDefined classes
         local_tycons  = [ tc | tc <- tycons,
     			       isLocallyDefined tc,
     			       not (isClassTyCon tc)
@@ -295,8 +291,8 @@ printTcDump dflags (Just (_,results))
 
 dump_tc results
   = vcat [ppr (tc_binds results),
-	  pp_rules (tc_rules results) --,
---	  ppr_gen_tycons (tc_tycons results)
+	  pp_rules (tc_rules results),
+	  ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)]
     ]
 
 dump_sigs results	-- Print type signatures