[project @ 2003-04-17 15:22:38 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 39c0a1f..927f7e2 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, moduleName, unitModuleEnv, foldModuleEnv )
+import Module          ( Module, unitModuleEnv, foldModuleEnv )
 import Name            ( Name, isInternalName )
 import Type            ( Type )
 import NameEnv         ( extendNameEnvList )
@@ -35,10 +35,12 @@ import Unique               ( Unique )
 import CmdLineOpts     ( DynFlags, DynFlag(..), dopt, opt_PprStyle_Debug )
 import BasicTypes      ( FixitySig )
 import Bag             ( snocBag, unionBags )
-
+import Panic           ( showException )
+ 
 import Maybe           ( isJust )
 import IO              ( stderr )
 import DATA_IOREF      ( newIORef, readIORef )
+import EXCEPTION       ( Exception )
 \end{code}
 
 %************************************************************************
@@ -114,7 +116,8 @@ initTc  (HscEnv { hsc_mode   = ghci_mode,
        usg_var  <- newIORef emptyUsages ;
        nc_var   <- newIORef (pcs_nc pcs) ;
        eps_var  <- newIORef eps ;
-   
+       ie_var   <- newIORef (mkImpInstEnv dflags eps hpt) ;
+
        let {
             env = Env { env_top = top_env,
                         env_gbl = gbl_env,
@@ -137,8 +140,7 @@ initTc  (HscEnv { hsc_mode   = ghci_mode,
                tcg_fix_env  = emptyFixityEnv,
                tcg_default  = defaultDefaultTys,
                tcg_type_env = emptyNameEnv,
-               tcg_ist      = mkImpTypeEnv eps hpt,
-               tcg_inst_env = mkImpInstEnv dflags eps hpt,
+               tcg_inst_env = ie_var,
                tcg_exports  = [],
                tcg_imports  = init_imports,
                tcg_binds    = EmptyMonoBinds,
@@ -187,6 +189,12 @@ defaultDefaultTys :: [Type]
 defaultDefaultTys = [integerTy, doubleTy]
 
 mkImpInstEnv :: DynFlags -> ExternalPackageState -> HomePackageTable -> InstEnv
+-- At the moment we (wrongly) build an instance environment from all the
+-- modules we have already compiled:
+--     (a) eps_inst_env from the external package state
+--     (b) all the md_insts in the home package table
+-- We should really only get instances from modules below us in the 
+-- module import tree.
 mkImpInstEnv dflags eps hpt
   = foldModuleEnv (add . md_insts . hm_details) 
                  (eps_inst_env eps)
@@ -238,6 +246,12 @@ updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
 
 setLclEnv :: m -> TcRn m a -> TcRn n a
 setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
+
+getEnvs :: TcRn m (TcGblEnv, m)
+getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }
+
+setEnvs :: (TcGblEnv, m) -> TcRn m a -> TcRn m a
+setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
 \end{code}
 
 Command-line flags
@@ -364,14 +378,6 @@ addMessages (m_warns, m_errs)
         (warns, errs) <- readMutVar errs_var ;
         writeMutVar errs_var (warns `unionBags` m_warns,
                               errs  `unionBags` m_errs) }
-
-checkGHCI :: Message -> TcRn m ()      -- Check that GHCI is on
-                                       -- otherwise add the error message
-#ifdef GHCI 
-checkGHCI m = returnM ()
-#else
-checkGHCI m = addErr m
-#endif
 \end{code}
 
 
@@ -380,7 +386,7 @@ recoverM :: TcRn m r        -- Recovery action; do this if the main one fails
         -> TcRn m r    -- Main action: do this first
         -> TcRn m r
 recoverM recover thing 
-  = do { mb_res <- tryM thing ;
+  = do { mb_res <- try_m thing ;
         case mb_res of
           Left exn  -> recover
           Right res -> returnM res }
@@ -396,7 +402,7 @@ tryTc :: TcRn m a -> TcRn m (Messages, Maybe a)
 tryTc m 
  = do {        errs_var <- newMutVar emptyMessages ;
        
-       mb_r <- tryM (setErrsVar errs_var m) ; 
+       mb_r <- try_m (setErrsVar errs_var m) ; 
 
        new_errs <- readMutVar errs_var ;
 
@@ -404,11 +410,21 @@ tryTc m
 
        return (new_errs, 
                case mb_r of
-                 Left exn                              -> Nothing
+                 Left exn -> Nothing
                  Right r | errorsFound dflags new_errs -> Nothing
                          | otherwise                   -> Just r) 
    }
 
+try_m :: TcRn m r -> TcRn m (Either Exception r)
+-- Does try_m, with a debug-trace on failure
+try_m thing 
+  = do { mb_r <- tryM thing ;
+        case mb_r of 
+            Left exn -> do { traceTc (exn_msg exn); return mb_r }
+            Right r  -> return mb_r }
+  where
+    exn_msg exn = text "recoverM recovering from" <+> text (showException exn)
+
 tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
 -- Just like tryTc, except that it ensures that the LIE
 -- for the thing is propagated only if there are no errors
@@ -419,7 +435,7 @@ tryTcLIE thing_inside
         return (errs, mb_r) }
 
 tryTcLIE_ :: TcM r -> TcM r -> TcM r
--- (tryM_ r m) tries m; if it succeeds it returns it,
+-- (tryTcLIE_ r m) tries m; if it succeeds it returns it,
 -- otherwise it returns r.  Any error messages added by m are discarded,
 -- whether or not m succeeds.
 tryTcLIE_ recover main
@@ -466,6 +482,7 @@ forkM :: SDoc -> TcM a -> TcM (Maybe a)
 -- Run thing_inside in an interleaved thread.  It gets a separate
 --     * errs_var, and
 --     * unique supply, 
+--     * LIE var is set to bottom (should never be used)
 -- but everything else is shared, so this is DANGEROUS.  
 --
 -- It returns Nothing if the computation fails
@@ -477,13 +494,19 @@ forkM doc thing_inside
  = do {        us <- newUniqueSupply ;
        unsafeInterleaveM $
        do { us_var <- newMutVar us ;
-            (msgs, mb_res) <- tryTcLIE (setUsVar us_var thing_inside) ;
+            (msgs, mb_res) <- tryTc (setLIEVar (panic "forkM: LIE used") $
+                                     setUsVar us_var thing_inside) ;
             case mb_res of
                Just r  -> return (Just r) 
                Nothing -> do {
-                   -- Bleat about errors in the forked thread
-                   ioToTcRn (do { printErrs (hdr_doc defaultErrStyle) ;
-                                  printErrorsAndWarnings msgs }) ;
+
+                   -- Bleat about errors in the forked thread, if -ddump-tc-trace is on
+                   -- Otherwise we silently discard errors. Errors can legitimately
+                   -- happen when compiling interface signatures (see tcInterfaceSigs)
+                   ifOptM Opt_D_dump_tc_trace 
+                     (ioToTcRn (do { printErrs (hdr_doc defaultErrStyle) ;
+                                     printErrorsAndWarnings msgs })) ;
+
                    return Nothing }
        }}
   where