[project @ 2001-02-23 12:24:10 by simonmar]

Fix a problem with duplicate instances appearing in the interpreter
after reloading modules.

ghc/compiler/main/HscMain.lhs

@@ -156,16 +156,13 @@ hscNoRecomp ghci_mode dflags location (Just old_iface) hst hit pcs_ch
       else do {
 
       -- TYPECHECK
-      maybe_tc_result <- typecheckModule dflags pcs_cl hst 
-					 old_iface alwaysQualify (vanillaSyntaxMap, cl_hs_decls)
-					 False{-don't check for Main.main-};
+      maybe_tc_result 
+	<- typecheckIface dflags pcs_cl hst old_iface (vanillaSyntaxMap, cl_hs_decls);
+
       case maybe_tc_result of {
          Nothing -> return (HscFail pcs_cl);
-         Just (pcs_tc, tc_result) -> do {
+         Just (pcs_tc, env_tc, local_rules) -> do {
 
-      let env_tc      = tc_env tc_result
-          local_rules = tc_rules tc_result
-      ;
       -- create a new details from the closed, typechecked, old iface
       let new_details = mkModDetailsFromIface env_tc local_rules
       ;
@@ -216,7 +213,6 @@ hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch
 	; maybe_tc_result 
 	    <- _scc_ "TypeCheck" typecheckModule dflags pcs_rn hst new_iface 
 					     print_unqualified rn_hs_decls 
-					     True{-check for Main.main if necessary-}
 	; case maybe_tc_result of {
       	     Nothing -> return (HscFail pcs_ch{-was: pcs_rn-});
       	     Just (pcs_tc, tc_result) -> do {

ghc/compiler/typecheck/TcDeriv.lhs

@@ -247,7 +247,7 @@ tcDeriving prs mod inst_env_in get_fixity tycl_decls
 	-- Make a Real dfun instead of the dummy one we have so far
     gen_inst_info :: DFunId -> RenamedMonoBinds -> InstInfo
     gen_inst_info dfun binds
-      = InstInfo { iLocal = True,  iDFunId = dfun, 
+      = InstInfo { iDFunId = dfun, 
 		   iBinds = binds, iPrags = [] }
 
     rn_meths meths = rnMethodBinds [] meths `thenRn` \ (meths', _) -> returnRn meths'

ghc/compiler/typecheck/TcEnv.lhs

@@ -57,8 +57,8 @@ import DataCon		( DataCon )
 import TyCon		( TyCon )
 import Class		( Class, ClassOpItem, ClassContext )
 import Name		( Name, OccName, NamedThing(..), 
-			  nameOccName, getSrcLoc, mkLocalName,
-			  isLocalName, nameModule_maybe
+			  nameOccName, getSrcLoc, mkLocalName, isLocalName,
+			  nameIsLocalOrFrom, nameModule_maybe
 			)
 import Name		( NameEnv, lookupNameEnv, nameEnvElts, extendNameEnvList, emptyNameEnv )
 import OccName		( mkDFunOcc, occNameString )
@@ -261,11 +261,7 @@ newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
 
 \begin{code}
 isLocalThing :: NamedThing a => Module -> a -> Bool
-  -- True if the thing has a Local name, 
-  -- or a Global name from the specified module
-isLocalThing mod thing = case nameModule_maybe (getName thing) of
-			   Nothing -> True	-- A local name
-			   Just m  -> m == mod	-- A global thing
+isLocalThing mod thing = nameIsLocalOrFrom mod (getName thing)
 \end{code}
 
 %************************************************************************
@@ -509,7 +505,6 @@ The InstInfo type summarises the information in an instance declaration
 \begin{code}
 data InstInfo
   = InstInfo {
-      iLocal  :: Bool,			-- True <=> it's defined in this module
       iDFunId :: DFunId,		-- The dfun id
       iBinds  :: RenamedMonoBinds,	-- Bindings, b
       iPrags  :: [RenamedSig]		-- User pragmas recorded for generating specialised instances

ghc/compiler/typecheck/TcInstDcls.lhs

@@ -15,8 +15,8 @@ import HsSyn		( HsDecl(..), InstDecl(..), TyClDecl(..), HsType(..),
 			  MonoBinds(..), HsExpr(..),  HsLit(..), Sig(..), 
 			  andMonoBindList, collectMonoBinders, isClassDecl
 			)
-import RnHsSyn		( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, RenamedMonoBinds,
-			  RenamedTyClDecl, RenamedHsType, 
+import RnHsSyn		( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, 
+			  RenamedMonoBinds, RenamedTyClDecl, RenamedHsType, 
 			  extractHsTyVars, maybeGenericMatch
 			)
 import TcHsSyn		( TcMonoBinds, mkHsConApp )
@@ -31,8 +31,9 @@ import TcDeriv		( tcDeriving )
 import TcEnv		( TcEnv, tcExtendGlobalValEnv, 
 			  tcExtendTyVarEnvForMeths, 
 			  tcAddImportedIdInfo, tcLookupClass,
- 			  InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy, 
-			  newDFunName, tcExtendTyVarEnv
+ 			  InstInfo(..), pprInstInfo, simpleInstInfoTyCon, 
+			  simpleInstInfoTy, newDFunName, tcExtendTyVarEnv,
+			  isLocalThing,
 			)
 import InstEnv		( InstEnv, extendInstEnv )
 import TcMonoType	( tcTyVars, tcHsSigType, kcHsSigType, checkSigTyVars )
@@ -171,7 +172,7 @@ tcInstDecls1 :: PackageInstEnv
 	     -> [RenamedHsDecl]
 	     -> TcM (PackageInstEnv, InstEnv, [InstInfo], RenamedHsBinds)
 
-tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod decls
+tcInstDecls1 inst_env0 prs hst unf_env get_fixity this_mod decls
   = let
 	inst_decls = [inst_decl | InstD inst_decl <- decls]	
 	tycl_decls = [decl      | TyClD decl <- decls]
@@ -191,7 +192,8 @@ tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod decls
 	--	e) generic instances					inst_env4
 	-- The result of (b) replaces the cached InstEnv in the PCS
     let
-	(local_inst_info, imported_inst_info) = partition iLocal (concat inst_infos)
+	(local_inst_info, imported_inst_info) 
+		= partition (isLocalThing this_mod . iDFunId) (concat inst_infos)
 
 	imported_dfuns	 = map (tcAddImportedIdInfo unf_env . iDFunId) 
 			       imported_inst_info
@@ -207,7 +209,8 @@ tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod decls
 	--     we ignore deriving decls from interfaces!
 	-- This stuff computes a context for the derived instance decl, so it
 	-- needs to know about all the instances possible; hecne inst_env4
-    tcDeriving prs mod inst_env4 get_fixity tycl_decls	`thenTc` \ (deriv_inst_info, deriv_binds) ->
+    tcDeriving prs this_mod inst_env4 get_fixity tycl_decls
+					`thenTc` \ (deriv_inst_info, deriv_binds) ->
     addInstInfos inst_env4 deriv_inst_info		`thenNF_Tc` \ final_inst_env ->
 
     returnTc (inst_env1, 
@@ -267,7 +270,7 @@ tcInstDecl1 decl@(InstDecl poly_ty binds uprags maybe_dfun_name src_loc)
     let
 	dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta
     in
-    returnTc [InstInfo { iLocal = is_local, iDFunId = dfun_id, 
+    returnTc [InstInfo { iDFunId = dfun_id, 
 			 iBinds = binds,    iPrags = uprags }]
 \end{code}
 
@@ -406,7 +409,7 @@ mkGenericInstance clas loc (hs_ty, binds)
 	dfun_id    = mkDictFunId dfun_name clas tyvars inst_tys inst_theta
     in
 
-    returnTc (InstInfo { iLocal = True, iDFunId = dfun_id, 
+    returnTc (InstInfo { iDFunId = dfun_id, 
 		  	 iBinds = binds, iPrags = [] })
 \end{code}
 
@@ -498,15 +501,13 @@ is the @dfun_theta@ below.
 
 First comes the easy case of a non-local instance decl.
 
+
 \begin{code}
 tcInstDecl2 :: InstInfo -> NF_TcM (LIE, TcMonoBinds)
+-- tcInstDecl2 is called *only* on InstInfos 
 
-tcInstDecl2 (InstInfo { iLocal = is_local, iDFunId = dfun_id, 
+tcInstDecl2 (InstInfo { iDFunId = dfun_id, 
 			iBinds = monobinds, iPrags = uprags })
-  | not is_local
-  = returnNF_Tc (emptyLIE, EmptyMonoBinds)
-
-  | otherwise
   =	 -- Prime error recovery
     recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds))  $
     tcAddSrcLoc (getSrcLoc dfun_id)			   $

ghc/compiler/typecheck/TcModule.lhs

@@ -5,7 +5,7 @@
 
 \begin{code}
 module TcModule (
-	typecheckModule, typecheckExpr, TcResults(..)
+	typecheckModule, typecheckIface, typecheckExpr, TcResults(..)
     ) where
 
 #include "HsVersions.h"
@@ -82,18 +82,17 @@ typecheckModule
 	:: DynFlags
 	-> PersistentCompilerState
 	-> HomeSymbolTable
-	-> ModIface		-- Iface for this module
+	-> ModIface		-- Iface for this module (just module & fixities)
 	-> PrintUnqualified	-- For error printing
 	-> (SyntaxMap, [RenamedHsDecl])
-	-> Bool			-- True <=> check for Main.main if Module==Main
 	-> IO (Maybe (PersistentCompilerState, TcResults))
 			-- The new PCS is Augmented with imported information,
 						-- (but not stuff from this module)
 
 
-typecheckModule dflags pcs hst mod_iface unqual (syn_map, decls) check_main
+typecheckModule dflags pcs hst mod_iface unqual (syn_map, decls)
   = do	{ maybe_tc_result <- typecheck dflags syn_map pcs hst unqual $
-			     tcModule pcs hst get_fixity this_mod decls check_main
+			     tcModule pcs hst get_fixity this_mod decls
 	; printTcDump dflags maybe_tc_result
 	; return maybe_tc_result }
   where
@@ -103,6 +102,48 @@ typecheckModule dflags pcs hst mod_iface unqual (syn_map, decls) check_main
     get_fixity :: Name -> Maybe Fixity
     get_fixity nm = lookupNameEnv fixity_env nm
 
+---------------
+typecheckIface
+	:: DynFlags
+	-> PersistentCompilerState
+	-> HomeSymbolTable
+	-> ModIface		-- Iface for this module (just module & fixities)
+	-> (SyntaxMap, [RenamedHsDecl])
+	-> IO (Maybe (PersistentCompilerState, TypeEnv, [TypecheckedRuleDecl]))
+			-- The new PCS is Augmented with imported information,
+			-- (but not stuff from this module).
+			-- The TcResults returned contains only the environment
+			-- and rules.
+
+
+typecheckIface dflags pcs hst mod_iface (syn_map, decls)
+  = do	{ maybe_tc_stuff <- typecheck dflags syn_map pcs hst alwaysQualify $
+			    tcIfaceImports pcs hst get_fixity this_mod decls
+	; printIfaceDump dflags maybe_tc_stuff
+	; return maybe_tc_stuff }
+  where
+    this_mod   = mi_module   mod_iface
+    fixity_env = mi_fixities mod_iface
+
+    get_fixity :: Name -> Maybe Fixity
+    get_fixity nm = lookupNameEnv fixity_env nm
+
+    tcIfaceImports pcs hst get_fixity this_mod decls
+	= fixTc (\ ~(unf_env, _, _, _, _) ->
+	      tcImports unf_env pcs hst get_fixity this_mod decls
+          )	`thenTc` \ (env, new_pcs, local_inst_info, 
+			    deriv_binds, local_rules) ->
+	  ASSERT(nullBinds deriv_binds)
+	  let 
+	      local_things = filter (isLocalThing this_mod) 
+				 	(nameEnvElts (getTcGEnv env))
+	      local_type_env :: TypeEnv
+	      local_type_env = mkTypeEnv local_things
+	  in
+
+	  -- throw away local_inst_info
+          returnTc (new_pcs, local_type_env, local_rules)
+
 ---------------
 typecheckExpr :: DynFlags
 	      -> Bool			-- True <=> wrap in 'print' to get a result of IO type
@@ -205,10 +246,9 @@ tcModule :: PersistentCompilerState
 	 -> (Name -> Maybe Fixity)
 	 -> Module
 	 -> [RenamedHsDecl]
-	 -> Bool			-- True <=> check for Main.main if Mod==Main
 	 -> TcM (PersistentCompilerState, TcResults)
 
-tcModule pcs hst get_fixity this_mod decls check_main
+tcModule pcs hst get_fixity this_mod decls
   = fixTc (\ ~(unf_env, _, _) ->
 		-- Loop back the final environment, including the fully zonkec
 		-- versions of bindings from this module.  In the presence of mutual
@@ -261,9 +301,7 @@ tcModule pcs hst get_fixity this_mod decls check_main
 	tcSimplifyTop lie_alldecls			`thenTc` \ const_inst_binds ->
 	
 		-- CHECK THAT main IS DEFINED WITH RIGHT TYPE, IF REQUIRED
-	(if check_main 
-		then tcCheckMain this_mod
-		else returnTc ())		`thenTc_`
+	tcCheckMain this_mod		`thenTc_`
 	
 	    -- Backsubstitution.    This must be done last.
 	    -- Even tcSimplifyTop may do some unification.
@@ -466,22 +504,34 @@ noMainErr = hsep [ptext SLIT("Module") <+> quotes (ppr mAIN_Name),
 printTcDump dflags Nothing = return ()
 printTcDump dflags (Just (_, results))
   = do dumpIfSet_dyn dflags Opt_D_dump_types 
-                     "Type signatures" (dump_sigs results)
+                     "Type signatures" (dump_sigs (tc_env results))
        dumpIfSet_dyn dflags Opt_D_dump_tc    
                      "Typechecked" (dump_tc results) 
 
+printIfaceDump dflags Nothing = return ()
+printIfaceDump dflags (Just (_, env, rules))
+  = do dumpIfSet_dyn dflags Opt_D_dump_types 
+                     "Type signatures" (dump_sigs env)
+       dumpIfSet_dyn dflags Opt_D_dump_tc    
+                     "Typechecked" (dump_iface env rules) 
+
 dump_tc results
   = vcat [ppr (tc_binds results),
 	  pp_rules (tc_rules results),
 	  ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)]
     ]
 
-dump_sigs results	-- Print type signatures
+dump_iface env rules
+  = vcat [pp_rules rules,
+	  ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts env]
+    ]
+
+dump_sigs env	-- Print type signatures
   = 	-- Convert to HsType so that we get source-language style printing
 	-- And sort by RdrName
     vcat $ map ppr_sig $ sortLt lt_sig $
     [ (toRdrName id, toHsType (idType id))
-    | AnId id <- nameEnvElts (tc_env results),
+    | AnId id <- nameEnvElts env,
       want_sig id
     ]
   where