From c5eb828c4d5ec8bb278d0bfef8dd0c0d12e32ffe Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Thu, 12 Oct 2000 16:41:48 +0000
Subject: [PATCH] [project @ 2000-10-12 16:41:48 by simonpj] Mainly TcModule
 plumbing

---
 ghc/compiler/main/HscTypes.lhs      |   17 ++++++------
 ghc/compiler/typecheck/TcEnv.lhs    |    2 +-
 ghc/compiler/typecheck/TcModule.lhs |   50 ++++++++++++++++++++---------------
 3 files changed, 39 insertions(+), 30 deletions(-)

diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs
index b457bff..183daa5 100644
--- a/ghc/compiler/main/HscTypes.lhs
+++ b/ghc/compiler/main/HscTypes.lhs
@@ -63,11 +63,11 @@ emptyModDetails mod
 		 moduleExports = [],
 		 moduleEnv     = emptyRdrEnv,
 		 fixityEnv     = emptyNameEnv,
-		 deptecEnv     = emptyNameEnv,
+		 deprecEnv     = emptyNameEnv,
 		 typeEnv       = emptyNameEnv,
 		 instEnv       = emptyInstEnv,
-    }		 ruleEnv       = emptyRuleEnv
-		
+    		 ruleEnv       = emptyRuleEnv
+    }		
 \end{code}
 
 Symbol tables map modules to ModDetails:
@@ -121,9 +121,10 @@ lookupTypeEnv tbl name
 	Nothing	     -> Nothing
 
 
-groupTyThings :: [TyThing] -> [(Module, TypeEnv)]
+groupTyThings :: [TyThing] -> FiniteMap Module TypeEnv
+  -- Finite map because we want the range too
 groupTyThings things
-  = fmToList (foldl add emptyFM things)
+  = foldl add emptyFM things
   where
     add :: FiniteMap Module TypeEnv -> TyThing -> FiniteMap Module TypeEnv
     add tbl thing = addToFM tbl mod new_env
@@ -134,11 +135,11 @@ groupTyThings things
 				Nothing  -> unitNameEnv name thing
 				Just env -> extendNameEnv env name thing
 		
-extendTypeEnv :: SymbolTable -> [TyThing] -> SymbolTable
+extendTypeEnv :: SymbolTable -> FiniteMap Module TypeEnv -> SymbolTable
 extendTypeEnv tbl things
-  = foldl add tbl (groupTyThings things)
+  = foldFM add tbl things
   where
-    add tbl (mod,type_env)
+    add mod type_env tbl
 	= extendModuleEnv mod new_details
 	where
 	  new_details = case lookupModuleEnv tbl mod of
diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 0444dd9..13ce1ef 100644
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -62,7 +62,7 @@ import Name	( Name, OccName, Provenance(..), ExportFlag(..), NamedThing(..),
 import OccName	( mkDFunOcc, mkDefaultMethodOcc, occNameString )
 import Module	( Module )
 import Unify	( unifyTyListsX, matchTys )
-import HscTypes	( ModDetails(..), lookupTypeEnv )
+import HscTypes	( ModDetails(..), InstEnv, lookupTypeEnv )
 import Unique	( pprUnique10, Unique, Uniquable(..) )
 import UniqFM
 import Unique	( Uniquable(..) )
diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index 8997884..2058e29 100644
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -68,15 +68,13 @@ Outside-world interface:
 -- Convenient type synonyms first:
 data TcResults
   = TcResults {
-	tc_prs	   :: PersistentCompilerState,	-- Augmented with imported information,
+	tc_pcs	   :: PersistentCompilerState,	-- Augmented with imported information,
 						-- (but not stuff from this module)
+	tc_env	   :: TypeEnv,			-- The TypeEnv just for the stuff from this module
 	tc_binds   :: TypecheckedMonoBinds,
-	tc_tycons  :: [TyCon],
-	tc_classes :: [Class],
-	tc_insts   :: Bag InstInfo,		-- Instance declaration information
+	tc_insts   :: InstEnv,			-- Instances, just for this module
 	tc_fords   :: [TypecheckedForeignDecl], -- Foreign import & exports.
 	tc_rules   :: [TypecheckedRuleDecl],	-- Transformation rules
-	tc_env	   :: ValueEnv
     }
 
 ---------------
@@ -84,7 +82,7 @@ typecheckModule
 	:: PersistentCompilerState
 	-> HomeSymbolTable
 	-> RenamedHsModule
-	-> IO (Maybe TcResults)
+	-> IO (Maybe (PersistentCompilerState, TcResults))
 
 typecheckModule pcs hst mod
   = do { us <- mkSplitUniqSupply 'a' ;
@@ -95,17 +93,29 @@ typecheckModule pcs hst mod
 		
 	 printErrorsAndWarnings errs warns ;
 	
-	 (case maybe_result of
-		Nothing -> return ()
-		Just results -> do { dumpIfSet opt_D_dump_types "Type signatures" (dump_sigs results)
-				     dumpIfSet opt_D_dump_tc    "Typechecked"     (dump_tc   results)
-	 }) ;
+	 case maybe_result of {
+	    Nothing      -> return Nothing ;
+	    Just results -> do { 
+
+	 dumpIfSet opt_D_dump_types "Type signatures" (dump_sigs results) ;
+         dumpIfSet opt_D_dump_tc    "Typechecked"     (dump_tc   results) ;
 			
-	return (if isEmptyBag errs then 
-			maybe_result 
-		else 
-			Nothing)
-    }
+	 if isEmptyBag errs then 
+	    return Nothing 
+	 else
+
+	 let	groups :: FiniteMap Module TypeEnv
+		groups = groupTyThings (nameEnvElts (tc_env results))
+
+		local_type_env :: TypeEnv
+		local_type_env = lookupWithDefaultFM groups this_mod emptyNameEnv
+
+		new_pst :: PackageSymbolTable
+		new_pst = extendTypeEnv (pcsPST pcs) (delFromFM groups this_mod)
+	   ;
+	 return (Just (pcs {pcsPST = new_pst}, 
+		       results {tc_env = local_type_env}))
+    }}}
   where
     global_symbol_table = pcsPST pcs `plusModuleEnv` hst
 
@@ -256,13 +266,11 @@ tcModule prs (HsModule mod_name _ _ _ decls _ src_loc)
 	zonkRules rules			`thenNF_Tc` \ rules' ->
 
 	returnTc (really_final_env, 
-		  (TcResults {	tc_binds   = all_binds', 
-				tc_tycons  = local_tycons,
-				tc_classes = local_classes,
+		  (TcResults {	tc_env     = tcGEnv really_final_env,
+				tc_binds   = all_binds', 
 				tc_insts   = inst_info,
 				tc_fords   = foi_decls ++ foe_decls',
-				tc_rules   = rules',
-				tc_env     = really_final_env
+				tc_rules   = rules'
 		 }))
 
     -- End of outer fix loop
-- 
1.7.10.4