[project @ 2002-11-21 11:31:34 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcRnMonad.lhs

diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs
index 58930ac..550cf60 100644 (file)
--- a/ghc/compiler/typecheck/TcRnMonad.lhs
+++ b/ghc/compiler/typecheck/TcRnMonad.lhs
@@ -14,7 +14,7 @@ import HscTypes               ( HscEnv(..), PersistentCompilerState(..),
                          GlobalRdrEnv, LocalRdrEnv, NameCache, FixityEnv,
                          GhciMode, lookupType, unQualInScope )
 import TcRnTypes
-import Module          ( Module, foldModuleEnv )
+import Module          ( Module, moduleName, unitModuleEnv, foldModuleEnv )
 import Name            ( Name, isInternalName )
 import Type            ( Type )
 import NameEnv         ( extendNameEnvList )
@@ -140,7 +140,7 @@ initTc  (HscEnv { hsc_mode   = ghci_mode,
                tcg_ist      = mkImpTypeEnv eps hpt,
                tcg_inst_env = mkImpInstEnv dflags eps hpt,
                tcg_exports  = [],
-               tcg_imports  = emptyImportAvails,
+               tcg_imports  = init_imports,
                tcg_binds    = EmptyMonoBinds,
                tcg_deprecs  = NoDeprecs,
                tcg_insts    = [],
@@ -169,14 +169,20 @@ initTc  (HscEnv { hsc_mode   = ghci_mode,
        eps' <- readIORef eps_var ;
        nc'  <- readIORef nc_var ;
        let { pcs' = PCS { pcs_EPS = eps', pcs_nc = nc' } ;
-             final_res | errorsFound msgs = Nothing
-                       | otherwise        = maybe_res } ;
+             final_res | errorsFound dflags msgs = Nothing
+                       | otherwise               = maybe_res } ;
 
        return (pcs', final_res)
     }
   where
     eps = pcs_EPS pcs
 
+    init_imports = emptyImportAvails { imp_qual = unitModuleEnv mod emptyAvailEnv }
+       -- Initialise tcg_imports with an empty set of bindings for
+       -- this module, so that if we see 'module M' in the export
+       -- list, and there are no bindings in M, we don't bleat 
+       -- "unknown module M".
+
 defaultDefaultTys :: [Type]
 defaultDefaultTys = [integerTy, doubleTy]
 
@@ -276,6 +282,9 @@ getModule = do { env <- getGblEnv; return (tcg_mod env) }
 getGlobalRdrEnv :: TcRn m GlobalRdrEnv
 getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
 
+getImports :: TcRn m ImportAvails
+getImports = do { env <- getGblEnv; return (tcg_imports env) }
+
 getFixityEnv :: TcRn m FixityEnv
 getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }
 
@@ -289,13 +298,13 @@ getDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
 \end{code}
 
 \begin{code}
-getUsageVar :: TcRn m (TcRef Usages)
+getUsageVar :: TcRn m (TcRef EntityUsage)
 getUsageVar = do { env <- getGblEnv; return (tcg_usages env) }
 
-getUsages :: TcRn m Usages
+getUsages :: TcRn m EntityUsage
 getUsages = do { usg_var <- getUsageVar; readMutVar usg_var }
 
-updUsages :: (Usages -> Usages) -> TcRn m () 
+updUsages :: (EntityUsage -> EntityUsage) -> TcRn m () 
 updUsages upd = do { usg_var <- getUsageVar ;
                     usg <- readMutVar usg_var ;
                     writeMutVar usg_var (upd usg) }
@@ -391,11 +400,13 @@ tryTc m
 
        new_errs <- readMutVar errs_var ;
 
+       dflags <- getDOpts ;
+
        return (new_errs, 
                case mb_r of
-                 Left exn                       -> Nothing
-                 Right r | errorsFound new_errs -> Nothing
-                         | otherwise            -> Just r) 
+                 Left exn                              -> Nothing
+                 Right r | errorsFound dflags new_errs -> Nothing
+                         | otherwise                   -> Just r) 
    }
 
 tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
@@ -439,7 +450,8 @@ ifErrsM :: TcRn m r -> TcRn m r -> TcRn m r
 ifErrsM bale_out normal
  = do { errs_var <- getErrsVar ;
        msgs <- readMutVar errs_var ;
-       if errorsFound msgs then
+       dflags <- getDOpts ;
+       if errorsFound dflags msgs then
           bale_out
        else    
           normal }