X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnMonad.lhs;h=927f7e2992cfb88dc2ee957c046f9ee820a4b3c8;hb=136d634590dfed8008c084e2418e7c1663924829;hp=07dbe1200e6f8e73a5405307527c833712ec6200;hpb=5c614bc5f79ac6134e081e71c5db97495e52e1e2;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs
index 07dbe12..927f7e2 100644
--- 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, 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,
@@ -169,25 +171,30 @@ 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 = mkImportAvails (moduleName mod) True []
+    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]
 
 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)
@@ -239,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
@@ -283,6 +296,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) }
 
@@ -296,13 +312,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) }
@@ -362,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}
 
 
@@ -378,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 }
@@ -394,17 +402,29 @@ 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 ;
 
+	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) 
    }
 
+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
@@ -415,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
@@ -446,7 +466,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 }
@@ -461,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
@@ -472,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
@@ -577,7 +605,13 @@ updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
 getInstLoc :: InstOrigin -> TcM InstLoc
 getInstLoc origin
   = do { loc <- getSrcLocM ; env <- getLclEnv ;
-	 return (origin, loc, (tcl_ctxt env)) }
+	 return (InstLoc origin loc (tcl_ctxt env)) }
+
+addInstCtxt :: InstLoc -> TcM a -> TcM a
+-- Add the SrcLoc and context from the first Inst in the list
+-- 	(they all have similar locations)
+addInstCtxt (InstLoc _ src_loc ctxt) thing_inside
+  = addSrcLoc src_loc (updCtxt (\ old_ctxt -> ctxt) thing_inside)
 \end{code}
 
     The addErrTc functions add an error message, but do not cause failure.
@@ -596,12 +630,6 @@ addErrTcM (tidy_env, err_msg)
   = do { ctxt <- getErrCtxt ;
 	 loc  <- getSrcLocM ;
 	 add_err_tcm tidy_env err_msg loc ctxt }
-
-addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> TcM ()
-addInstErrTcM inst_loc@(_, loc, ctxt) (tidy_env, err_msg)
-  = add_err_tcm tidy_env err_msg loc full_ctxt
-  where
-    full_ctxt = (\env -> returnM (env, pprInstLoc inst_loc)) : ctxt
 \end{code}
 
 The failWith functions add an error message and cause failure