[project @ 2000-10-12 16:41:48 by simonpj]

Mainly TcModule plumbing

diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs
index b457bff..183daa5 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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