X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnMonad.lhs;h=350aca0876b3297837b4774a21c6fc50469196f1;hb=29da2cf3011c292bc4261601aff85afb13e24d54;hp=f450dcfbad33c6f0d3f9e14d507ef8f4da80ad62;hpb=8c1b6bd7ffb9ce97da7a72f9e102998df19b23a2;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs
index f450dcf..350aca0 100644
--- a/ghc/compiler/typecheck/TcRnMonad.lhs
+++ b/ghc/compiler/typecheck/TcRnMonad.lhs
@@ -1,92 +1,53 @@
 \begin{code}
 module TcRnMonad(
 	module TcRnMonad,
-	module TcRnTypes
+	module TcRnTypes,
+	module IOEnv
   ) where
 
 #include "HsVersions.h"
 
-import HsSyn		( MonoBinds(..) )
-import HscTypes		( HscEnv(..), PersistentCompilerState(..),
-			  emptyFixityEnv, emptyGlobalRdrEnv, TyThing,
+import TcRnTypes	-- Re-export all
+import IOEnv		-- Re-export all
+
+import HscTypes		( HscEnv(..), ModGuts(..), ModIface(..),
+			  TyThing, Dependencies(..), TypeEnv, emptyTypeEnv,
 			  ExternalPackageState(..), HomePackageTable,
-			  ModDetails(..), HomeModInfo(..), Deprecations(..),
-			  GlobalRdrEnv, LocalRdrEnv, NameCache, FixityEnv,
+			  ModDetails(..), HomeModInfo(..), 
+			  Deprecs(..), FixityEnv, FixItem,
 			  GhciMode, lookupType, unQualInScope )
-import TcRnTypes
-import Module		( Module, foldModuleEnv )
+import Module		( Module, ModuleName, unitModuleEnv, foldModuleEnv, emptyModuleEnv )
+import RdrName		( GlobalRdrEnv, emptyGlobalRdrEnv, 	
+			  LocalRdrEnv, emptyLocalRdrEnv )
 import Name		( Name, isInternalName )
 import Type		( Type )
 import NameEnv		( extendNameEnvList )
-import InstEnv		( InstEnv, extendInstEnv )
-import TysWiredIn	( integerTy, doubleTy )
+import InstEnv		( InstEnv, emptyInstEnv, extendInstEnv )
 
 import VarSet		( emptyVarSet )
 import VarEnv		( TidyEnv, emptyTidyEnv )
-import RdrName		( emptyRdrEnv )
 import ErrUtils		( Message, Messages, emptyMessages, errorsFound, 
-			  addShortErrLocLine, addShortWarnLocLine, printErrorsAndWarnings )
-import SrcLoc		( SrcLoc, noSrcLoc )
+			  mkErrMsg, mkWarnMsg, printErrorsAndWarnings,
+			  mkLocMessage, mkLongErrMsg )
+import SrcLoc		( mkGeneralSrcSpan, SrcSpan, Located(..) )
 import NameEnv		( emptyNameEnv )
+import NameSet		( emptyDUs, emptyNameSet )
+import OccName		( emptyOccEnv )
+import Module		( moduleName )
 import Bag		( emptyBag )
 import Outputable
 import UniqSupply	( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply )
 import Unique		( Unique )
-import CmdLineOpts	( DynFlags, DynFlag(..), dopt, opt_PprStyle_Debug )
-import BasicTypes	( FixitySig )
+import CmdLineOpts	( DynFlags, DynFlag(..), dopt, opt_PprStyle_Debug, dopt_set )
 import Bag		( snocBag, unionBags )
-
+import Panic		( showException )
+ 
 import Maybe		( isJust )
 import IO		( stderr )
 import DATA_IOREF	( newIORef, readIORef )
+import EXCEPTION	( Exception )
 \end{code}
 
-%************************************************************************
-%*									*
-	Standard combinators, but specialised for this monad
-			(for efficiency)
-%*									*
-6%************************************************************************
-
-\begin{code}
-mappM  	      :: (a -> TcRn m b) -> [a] -> TcRn m [b]
-mappM_ 	      :: (a -> TcRn m b) -> [a] -> TcRn m ()
-	-- Funny names to avoid clash with Prelude
-sequenceM     :: [TcRn m a] -> TcRn m [a]
-foldlM        :: (a -> b -> TcRn m a)  -> a -> [b] -> TcRn m a
-mapAndUnzipM  :: (a -> TcRn m (b,c))   -> [a] -> TcRn m ([b],[c])
-mapAndUnzip3M :: (a -> TcRn m (b,c,d)) -> [a] -> TcRn m ([b],[c],[d])
-checkM	      :: Bool -> TcRn m () -> TcRn m ()	-- Perform arg if bool is False
-ifM	      :: Bool -> TcRn m () -> TcRn m ()	-- Perform arg if bool is True
-
-mappM f []     = return []
-mappM f (x:xs) = do { r <- f x; rs <- mappM f xs; return (r:rs) }
-
-mappM_ f []     = return ()
-mappM_ f (x:xs) = f x >> mappM_ f xs
-
-sequenceM [] = return []
-sequenceM (x:xs) = do { r <- x; rs <- sequenceM xs; return (r:rs) }
-
-foldlM k z [] = return z
-foldlM k z (x:xs) = do { r <- k z x; foldlM k r xs }
-
-mapAndUnzipM f []     = return ([],[])
-mapAndUnzipM f (x:xs) = do { (r,s) <- f x; 
-			     (rs,ss) <- mapAndUnzipM f xs; 
-			     return (r:rs, s:ss) }
-
-mapAndUnzip3M f []     = return ([],[], [])
-mapAndUnzip3M f (x:xs) = do { (r,s,t) <- f x; 
-			      (rs,ss,ts) <- mapAndUnzip3M f xs; 
-			      return (r:rs, s:ss, t:ts) }
-
-checkM True  err = return ()
-checkM False err = err
-
-ifM True  do_it = do_it
-ifM False do_it = return ()
-\end{code}
 
 
 %************************************************************************
@@ -96,101 +57,89 @@ ifM False do_it = return ()
 %************************************************************************
 
 \begin{code}
-initTc :: HscEnv -> PersistentCompilerState
+ioToTcRn :: IO r -> TcRn r
+ioToTcRn = ioToIOEnv
+\end{code}
+
+\begin{code}
+initTc :: HscEnv
        -> Module 
        -> TcM r
-       -> IO (PersistentCompilerState, Maybe r)
+       -> IO (Messages, Maybe r)
 		-- Nothing => error thrown by the thing inside
 		-- (error messages should have been printed already)
 
-initTc  (HscEnv { hsc_mode   = ghci_mode,
-		  hsc_HPT    = hpt,
-		  hsc_dflags = dflags })
-	pcs mod do_this
- = do { us       <- mkSplitUniqSupply 'a' ;
-      	us_var   <- newIORef us ;
-      	errs_var <- newIORef (emptyBag, emptyBag) ;
-      	tvs_var  <- newIORef emptyVarSet ;
-	usg_var  <- newIORef emptyUsages ;
-	nc_var   <- newIORef (pcs_nc pcs) ;
-	eps_var  <- newIORef eps ;
-   
-      	let {
-	     env = Env { env_top = top_env,
-			 env_gbl = gbl_env,
-			 env_lcl = lcl_env,
-			 env_loc = noSrcLoc } ;
-
-	     top_env = TopEnv { 
-		top_mode   = ghci_mode,
-		top_dflags = dflags,
-		top_eps    = eps_var,
-		top_hpt	   = hpt,
-		top_nc	   = nc_var,
-		top_us	   = us_var,
-		top_errs   = errs_var } ;
+initTc hsc_env mod do_this
+ = do { errs_var     <- newIORef (emptyBag, emptyBag) ;
+      	tvs_var      <- newIORef emptyVarSet ;
+	type_env_var <- newIORef emptyNameEnv ;
+	dfuns_var    <- newIORef emptyNameSet ;
 
+      	let {
 	     gbl_env = TcGblEnv {
 		tcg_mod      = mod,
-		tcg_usages   = usg_var,
 		tcg_rdr_env  = emptyGlobalRdrEnv,
-		tcg_fix_env  = emptyFixityEnv,
-		tcg_default  = defaultDefaultTys,
+		tcg_fix_env  = emptyNameEnv,
+		tcg_default  = Nothing,
 		tcg_type_env = emptyNameEnv,
-		tcg_ist      = mkImpTypeEnv eps hpt,
-		tcg_inst_env = mkImpInstEnv dflags eps hpt,
-		tcg_exports  = [],
-		tcg_imports  = emptyImportAvails,
-		tcg_binds    = EmptyMonoBinds,
+		tcg_type_env_var = type_env_var,
+		tcg_inst_env  = mkImpInstEnv hsc_env,
+		tcg_inst_uses = dfuns_var,
+		tcg_exports  = emptyNameSet,
+		tcg_imports  = init_imports,
+		tcg_dus      = emptyDUs,
+		tcg_binds    = emptyBag,
 		tcg_deprecs  = NoDeprecs,
 		tcg_insts    = [],
 		tcg_rules    = [],
-		tcg_fords    = [] } ;
-
+		tcg_fords    = [],
+		tcg_keep     = emptyNameSet
+	     } ;
 	     lcl_env = TcLclEnv {
-		tcl_ctxt   = [],
-		tcl_level  = topStage,
-		tcl_env    = emptyNameEnv,
-		tcl_tyvars = tvs_var,
-		tcl_lie	   = panic "initTc:LIE" } ;
-			-- LIE only valid inside a getLIE
+		tcl_errs       = errs_var,
+		tcl_loc	       = mkGeneralSrcSpan FSLIT("Top level of module"),
+		tcl_ctxt       = [],
+		tcl_rdr	       = emptyLocalRdrEnv,
+		tcl_th_ctxt    = topStage,
+		tcl_arrow_ctxt = topArrowCtxt,
+		tcl_env        = emptyNameEnv,
+		tcl_tyvars     = tvs_var,
+		tcl_lie	       = panic "initTc:LIE"	-- LIE only valid inside a getLIE
 	     } ;
+	} ;
    
 	-- OK, here's the business end!
-	maybe_res <- catch (do { res  <- runTcRn env do_this ;
-				 return (Just res) })
-		 	   (\_ -> return Nothing) ;
+	maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
+			     do { r <- tryM do_this 
+				; case r of
+				    Right res -> return (Just res)
+				    Left _    -> return Nothing } ;
 
-	-- Print any error messages
+	-- Collect any error messages
 	msgs <- readIORef errs_var ;
-	printErrorsAndWarnings msgs ;
 
-	-- Get final PCS and return
-	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 } ;
+	let { dflags = hsc_dflags hsc_env
+	    ; final_res | errorsFound dflags msgs = Nothing
+			| otherwise	   	  = maybe_res } ;
 
-	return (pcs', final_res)
+	return (msgs, final_res)
     }
   where
-    eps = pcs_EPS pcs
-
-defaultDefaultTys :: [Type]
-defaultDefaultTys = [integerTy, doubleTy]
-
-mkImpInstEnv :: DynFlags -> ExternalPackageState -> HomePackageTable -> InstEnv
-mkImpInstEnv dflags eps hpt
-  = foldModuleEnv (add . md_insts . hm_details) 
-		  (eps_inst_env eps)
-		  hpt
+    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".
+
+mkImpInstEnv :: HscEnv -> InstEnv
+-- At the moment we (wrongly) build an instance environment from all the
+-- home-package modules we have already compiled.
+-- We should really only get instances from modules below us in the 
+-- module import tree.
+mkImpInstEnv (HscEnv {hsc_dflags = dflags, hsc_HPT = hpt})
+  = foldModuleEnv (add . md_insts . hm_details) emptyInstEnv hpt
   where
-	  -- We shouldn't get instance conflict errors from
-	  -- the package and home type envs
-    add dfuns inst_env = WARN( not (null errs), vcat (map snd errs) ) inst_env'
-		       where
-			 (inst_env', errs) = extendInstEnv dflags inst_env dfuns
+    add dfuns inst_env = foldl extendInstEnv inst_env dfuns
 
 -- mkImpTypeEnv makes the imported symbol table
 mkImpTypeEnv :: ExternalPackageState -> HomePackageTable
@@ -205,103 +154,202 @@ mkImpTypeEnv pcs hpt = lookup
 
 %************************************************************************
 %*									*
+		Initialisation
+%*									*
+%************************************************************************
+
+
+\begin{code}
+initTcRnIf :: Char		-- Tag for unique supply
+	   -> HscEnv
+	   -> gbl -> lcl 
+	   -> TcRnIf gbl lcl a 
+	   -> IO a
+initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside
+   = do	{ us     <- mkSplitUniqSupply uniq_tag ;
+	; us_var <- newIORef us ;
+
+	; let { env = Env { env_top = hsc_env,
+			    env_us  = us_var,
+			    env_gbl = gbl_env,
+			    env_lcl = lcl_env } }
+
+	; runIOEnv env thing_inside
+	}
+\end{code}
+
+%************************************************************************
+%*									*
 		Simple accessors
 %*									*
 %************************************************************************
 
 \begin{code}
-getTopEnv :: TcRn m TopEnv
+getTopEnv :: TcRnIf gbl lcl HscEnv
 getTopEnv = do { env <- getEnv; return (env_top env) }
 
-getGblEnv :: TcRn m TcGblEnv
+getGblEnv :: TcRnIf gbl lcl gbl
 getGblEnv = do { env <- getEnv; return (env_gbl env) }
 
-updGblEnv :: (TcGblEnv -> TcGblEnv) -> TcRn m a -> TcRn m a
+updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) -> 
 			  env { env_gbl = upd gbl })
 
-setGblEnv :: TcGblEnv -> TcRn m a -> TcRn m a
+setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })
 
-getLclEnv :: TcRn m m
+getLclEnv :: TcRnIf gbl lcl lcl
 getLclEnv = do { env <- getEnv; return (env_lcl env) }
 
-updLclEnv :: (m -> m) -> TcRn m a -> TcRn m a
+updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) -> 
 			  env { env_lcl = upd lcl })
 
-setLclEnv :: m -> TcRn m a -> TcRn n a
+setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
 setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
+
+getEnvs :: TcRnIf gbl lcl (gbl, lcl)
+getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }
+
+setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
+setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
 \end{code}
 
+
 Command-line flags
 
 \begin{code}
-getDOpts :: TcRn m DynFlags
-getDOpts = do { env <- getTopEnv; return (top_dflags env) }
+getDOpts :: TcRnIf gbl lcl DynFlags
+getDOpts = do { env <- getTopEnv; return (hsc_dflags env) }
 
-doptM :: DynFlag -> TcRn m Bool
+doptM :: DynFlag -> TcRnIf gbl lcl Bool
 doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) }
 
-ifOptM :: DynFlag -> TcRn m () -> TcRn m ()	-- Do it flag is true
+setOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+setOptM flag = updEnv (\ env@(Env { env_top = top }) ->
+			 env { env_top = top { hsc_dflags = dopt_set (hsc_dflags top) flag}} )
+
+ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()	-- Do it flag is true
 ifOptM flag thing_inside = do { b <- doptM flag; 
 				if b then thing_inside else return () }
 
-getGhciMode :: TcRn m GhciMode
-getGhciMode = do { env <- getTopEnv; return (top_mode env) }
+getGhciMode :: TcRnIf gbl lcl GhciMode
+getGhciMode = do { env <- getTopEnv; return (hsc_mode env) }
 \end{code}
 
 \begin{code}
-getSrcLocM :: TcRn m SrcLoc
-	-- Avoid clash with Name.getSrcLoc
-getSrcLocM = do { env <- getEnv; return (env_loc env) }
+getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
+getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }
+
+getEps :: TcRnIf gbl lcl ExternalPackageState
+getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }
+
+setEps :: ExternalPackageState -> TcRnIf gbl lcl ()
+setEps eps = do { env <- getTopEnv; writeMutVar (hsc_EPS env) eps }
+
+updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
+	  -> TcRnIf gbl lcl a
+updateEps upd_fn = do	{ eps_var <- getEpsVar
+			; eps <- readMutVar eps_var
+			; let { (eps', val) = upd_fn eps }
+			; writeMutVar eps_var eps'
+			; return val }
+
+updateEps_ :: (ExternalPackageState -> ExternalPackageState)
+	   -> TcRnIf gbl lcl ()
+updateEps_ upd_fn = do	{ eps_var <- getEpsVar
+			; updMutVar eps_var upd_fn }
+
+getHpt :: TcRnIf gbl lcl HomePackageTable
+getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
+\end{code}
+
+%************************************************************************
+%*									*
+		Unique supply
+%*									*
+%************************************************************************
 
-addSrcLoc :: SrcLoc -> TcRn m a -> TcRn m a
-addSrcLoc loc = updEnv (\env -> env { env_loc = loc })
+\begin{code}
+newUnique :: TcRnIf gbl lcl Unique
+newUnique = do { us <- newUniqueSupply ; 
+		 return (uniqFromSupply us) }
+
+newUniqueSupply :: TcRnIf gbl lcl UniqSupply
+newUniqueSupply
+ = do { env <- getEnv ;
+	let { u_var = env_us env } ;
+	us <- readMutVar u_var ;
+    	let { (us1, us2) = splitUniqSupply us } ;
+	writeMutVar u_var us1 ;
+	return us2 }
 \end{code}
 
+
+%************************************************************************
+%*									*
+		Debugging
+%*									*
+%************************************************************************
+
 \begin{code}
-getEps :: TcRn m ExternalPackageState
-getEps = do { env <- getTopEnv; readMutVar (top_eps env) }
+traceTc, traceRn :: SDoc -> TcRn ()
+traceRn      = dumpOptTcRn Opt_D_dump_rn_trace
+traceTc      = dumpOptTcRn Opt_D_dump_tc_trace
+traceSplice  = dumpOptTcRn Opt_D_dump_splices
+
+
+traceIf :: SDoc -> TcRnIf m n ()	
+traceIf      = dumpOptIf Opt_D_dump_if_trace
+traceHiDiffs = dumpOptIf Opt_D_dump_hi_diffs
+
+
+dumpOptIf :: DynFlag -> SDoc -> TcRnIf m n ()  -- No RdrEnv available, so qualify everything
+dumpOptIf flag doc = ifOptM flag $
+		     ioToIOEnv (printForUser stderr alwaysQualify doc)
+
+dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
+dumpOptTcRn flag doc = ifOptM flag $ do
+			{ ctxt <- getErrCtxt
+			; loc  <- getSrcSpanM
+			; ctxt_msgs <- do_ctxt emptyTidyEnv ctxt 
+			; let real_doc = mkLocMessage loc (vcat (doc : ctxt_to_use ctxt_msgs))
+			; dumpTcRn real_doc }
+
+dumpTcRn :: SDoc -> TcRn ()
+dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ;
+		    ioToTcRn (printForUser stderr (unQualInScope rdr_env) doc) }
+\end{code}
 
-setEps :: ExternalPackageState -> TcRn m ()
-setEps eps = do { env <- getTopEnv; writeMutVar (top_eps env) eps }
 
-getHpt :: TcRn m HomePackageTable
-getHpt = do { env <- getTopEnv; return (top_hpt env) }
+%************************************************************************
+%*									*
+		Typechecker global environment
+%*									*
+%************************************************************************
 
-getModule :: TcRn m Module
+\begin{code}
+getModule :: TcRn Module
 getModule = do { env <- getGblEnv; return (tcg_mod env) }
 
-getGlobalRdrEnv :: TcRn m GlobalRdrEnv
+getGlobalRdrEnv :: TcRn GlobalRdrEnv
 getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
 
-getFixityEnv :: TcRn m FixityEnv
+getImports :: TcRn ImportAvails
+getImports = do { env <- getGblEnv; return (tcg_imports env) }
+
+getFixityEnv :: TcRn FixityEnv
 getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }
 
-extendFixityEnv :: [(Name,FixitySig Name)] -> RnM a -> RnM a
+extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
 extendFixityEnv new_bit
   = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) -> 
 		env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})	     
 
-getDefaultTys :: TcRn m [Type]
+getDefaultTys :: TcRn (Maybe [Type])
 getDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
 \end{code}
 
-\begin{code}
-getUsageVar :: TcRn m (TcRef Usages)
-getUsageVar = do { env <- getGblEnv; return (tcg_usages env) }
-
-getUsages :: TcRn m Usages
-getUsages = do { usg_var <- getUsageVar; readMutVar usg_var }
-
-updUsages :: (Usages -> Usages) -> TcRn m () 
-updUsages upd = do { usg_var <- getUsageVar ;
-		     usg <- readMutVar usg_var ;
-		     writeMutVar usg_var (upd usg) }
-\end{code}
-
-
 %************************************************************************
 %*									*
 		Error management
@@ -309,74 +357,124 @@ updUsages upd = do { usg_var <- getUsageVar ;
 %************************************************************************
 
 \begin{code}
-getErrsVar :: TcRn m (TcRef Messages)
-getErrsVar = do { env <- getTopEnv; return (top_errs env) }
+getSrcSpanM :: TcRn SrcSpan
+	-- Avoid clash with Name.getSrcLoc
+getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) }
+
+addSrcSpan :: SrcSpan -> TcRn a -> TcRn a
+addSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc })
 
-setErrsVar :: TcRef Messages -> TcRn m a -> TcRn m a
-setErrsVar v = updEnv (\ env@(Env { env_top = top_env }) ->
-			 env { env_top = top_env { top_errs = v }})
+addLocM :: (a -> TcM b) -> Located a -> TcM b
+addLocM fn (L loc a) = addSrcSpan loc $ fn a
 
-addErr :: Message -> TcRn m ()
-addErr msg = do { loc <- getSrcLocM ; addErrAt loc msg }
+wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
+wrapLocM fn (L loc a) = addSrcSpan loc $ do b <- fn a; return (L loc b)
 
-addErrAt :: SrcLoc -> Message -> TcRn m ()
-addErrAt loc msg
+wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
+wrapLocFstM fn (L loc a) =
+  addSrcSpan loc $ do
+    (b,c) <- fn a
+    return (L loc b, c)
+
+wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c)
+wrapLocSndM fn (L loc a) =
+  addSrcSpan loc $ do
+    (b,c) <- fn a
+    return (b, L loc c)
+\end{code}
+
+
+\begin{code}
+getErrsVar :: TcRn (TcRef Messages)
+getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }
+
+setErrsVar :: TcRef Messages -> TcRn a -> TcRn a
+setErrsVar v = updLclEnv (\ env -> env { tcl_errs =  v })
+
+addErr :: Message -> TcRn ()
+addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg }
+
+addLocErr :: Located e -> (e -> Message) -> TcRn ()
+addLocErr (L loc e) fn = addErrAt loc (fn e)
+
+addErrAt :: SrcSpan -> Message -> TcRn ()
+addErrAt loc msg = addLongErrAt loc msg empty
+
+addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
+addLongErrAt loc msg extra
  = do {  errs_var <- getErrsVar ;
 	 rdr_env <- getGlobalRdrEnv ;
-	 let { err = addShortErrLocLine loc (unQualInScope rdr_env) msg } ;
+	 let { err = mkLongErrMsg loc (unQualInScope rdr_env) msg extra } ;
 	 (warns, errs) <- readMutVar errs_var ;
   	 writeMutVar errs_var (warns, errs `snocBag` err) }
 
-addErrs :: [(SrcLoc,Message)] -> TcRn m ()
+addErrs :: [(SrcSpan,Message)] -> TcRn ()
 addErrs msgs = mappM_ add msgs
 	     where
 	       add (loc,msg) = addErrAt loc msg
 
-addWarn :: Message -> TcRn m ()
-addWarn msg
+addReport :: Message -> TcRn ()
+addReport msg = do loc <- getSrcSpanM; addReportAt loc msg
+
+addReportAt :: SrcSpan -> Message -> TcRn ()
+addReportAt loc msg
   = do { errs_var <- getErrsVar ;
-	 loc <- getSrcLocM ;
 	 rdr_env <- getGlobalRdrEnv ;
-	 let { warn = addShortWarnLocLine loc (unQualInScope rdr_env) msg } ;
+	 let { warn = mkWarnMsg loc (unQualInScope rdr_env) msg } ;
 	 (warns, errs) <- readMutVar errs_var ;
   	 writeMutVar errs_var (warns `snocBag` warn, errs) }
 
-checkErr :: Bool -> Message -> TcRn m ()
+addWarn :: Message -> TcRn ()
+addWarn msg = addReport (ptext SLIT("Warning:") <+> msg)
+
+addWarnAt :: SrcSpan -> Message -> TcRn ()
+addWarnAt loc msg = addReportAt loc (ptext SLIT("Warning:") <+> msg)
+
+addLocWarn :: Located e -> (e -> Message) -> TcRn ()
+addLocWarn (L loc e) fn = addReportAt loc (fn e)
+
+checkErr :: Bool -> Message -> TcRn ()
 -- Add the error if the bool is False
 checkErr ok msg = checkM ok (addErr msg)
 
-warnIf :: Bool -> Message -> TcRn m ()
+warnIf :: Bool -> Message -> TcRn ()
 warnIf True  msg = addWarn msg
 warnIf False msg = return ()
 
-addMessages :: Messages -> TcRn m ()
+addMessages :: Messages -> TcRn ()
 addMessages (m_warns, m_errs)
   = do { errs_var <- getErrsVar ;
 	 (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
+discardWarnings :: TcRn a -> TcRn a
+-- Ignore warnings inside the thing inside;
+-- used to ignore-unused-variable warnings inside derived code
+-- With -dppr-debug, the effects is switched off, so you can still see
+-- what warnings derived code would give
+discardWarnings thing_inside
+  | opt_PprStyle_Debug = thing_inside
+  | otherwise
+  = do	{ errs_var <- newMutVar emptyMessages
+	; result <- setErrsVar errs_var thing_inside
+	; (_warns, errs) <- readMutVar errs_var
+	; addMessages (emptyBag, errs)
+	; return result }
 \end{code}
 
 
 \begin{code}
-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 :: TcRn r 	-- Recovery action; do this if the main one fails
+	 -> TcRn r	-- Main action: do this first
+	 -> TcRn 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 }
 
-tryTc :: TcRn m a -> TcRn m (Messages, Maybe a)
+tryTc :: TcRn a -> TcRn (Messages, Maybe a)
     -- (tryTc m) executes m, and returns
     --	Just r,  if m succeeds (returning r) and caused no errors
     --	Nothing, if m fails, or caused errors
@@ -387,17 +485,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 r -> TcRn (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 "tryTc/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
@@ -408,7 +518,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
@@ -432,112 +542,24 @@ checkNoErrs main
 	   Nothing -> failM
    }
 
-ifErrsM :: TcRn m r -> TcRn m r -> TcRn m r
+ifErrsM :: TcRn r -> TcRn r -> TcRn r
 --	ifErrsM bale_out main
 -- does 'bale_out' if there are errors in errors collection
 -- otherwise does 'main'
 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 }
 
-failIfErrsM :: TcRn m ()
+failIfErrsM :: TcRn ()
 -- Useful to avoid error cascades
 failIfErrsM = ifErrsM failM (return ())
 \end{code}
 
-\begin{code}
-forkM :: SDoc -> TcM a -> TcM (Maybe a)
--- Run thing_inside in an interleaved thread.  It gets a separate
--- 	* errs_var, and
---	* unique supply, 
--- but everything else is shared, so this is DANGEROUS.  
---
--- It returns Nothing if the computation fails
--- 
--- It's used for lazily type-checking interface
--- signatures, which is pretty benign
-
-forkM doc thing_inside
- = do {	us <- newUniqueSupply ;
-	unsafeInterleaveM $
-	do { us_var <- newMutVar us ;
-	     (msgs, mb_res) <- tryTcLIE (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 }) ;
-		    return Nothing }
-	}}
-  where
-    hdr_doc = text "forkM failed:" <+> doc
-\end{code}
-
-
-%************************************************************************
-%*									*
-		Unique supply
-%*									*
-%************************************************************************
-
-\begin{code}
-getUsVar :: TcRn m (TcRef UniqSupply)
-getUsVar = do { env <- getTopEnv; return (top_us env) }
-
-setUsVar :: TcRef UniqSupply -> TcRn m a -> TcRn m a
-setUsVar v = updEnv (\ env@(Env { env_top = top_env }) ->
-		       env { env_top = top_env { top_us = v }})
-
-newUnique :: TcRn m Unique
-newUnique = do { us <- newUniqueSupply ; 
-		 return (uniqFromSupply us) }
-
-newUniqueSupply :: TcRn m UniqSupply
-newUniqueSupply
- = do { u_var <- getUsVar ;
-	us <- readMutVar u_var ;
-    	let { (us1, us2) = splitUniqSupply us } ;
-	writeMutVar u_var us1 ;
-	return us2 }
-\end{code}
-
-
-\begin{code}
-getNameCache :: TcRn m NameCache
-getNameCache = do { TopEnv { top_nc = nc_var } <- getTopEnv; 
-		    readMutVar nc_var }
-
-setNameCache :: NameCache -> TcRn m ()
-setNameCache nc = do { TopEnv { top_nc = nc_var } <- getTopEnv; 
-		       writeMutVar nc_var nc }
-\end{code}
-
-
-%************************************************************************
-%*									*
-		Debugging
-%*									*
-%************************************************************************
-
-\begin{code}
-traceTc, traceRn :: SDoc -> TcRn a ()
-traceRn      = dumpOptTcRn Opt_D_dump_rn_trace
-traceTc      = dumpOptTcRn Opt_D_dump_tc_trace
-traceHiDiffs = dumpOptTcRn Opt_D_dump_hi_diffs
-
-dumpOptTcRn :: DynFlag -> SDoc -> TcRn a ()
-dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
-
-dumpTcRn :: SDoc -> TcRn a ()
-dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ;
-		    ioToTcRn (printForUser stderr (unQualInScope rdr_env) doc) }
-\end{code}
-
 
 %************************************************************************
 %*									*
@@ -568,8 +590,14 @@ 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)) }
+  = do { loc <- getSrcSpanM ; env <- getLclEnv ;
+	 return (InstLoc origin loc (tcl_ctxt env)) }
+
+addInstCtxt :: InstLoc -> TcM a -> TcM a
+-- Add the SrcSpan and context from the first Inst in the list
+-- 	(they all have similar locations)
+addInstCtxt (InstLoc _ src_loc ctxt) thing_inside
+  = addSrcSpan src_loc (updCtxt (\ old_ctxt -> ctxt) thing_inside)
 \end{code}
 
     The addErrTc functions add an error message, but do not cause failure.
@@ -586,14 +614,8 @@ addErrsTc err_msgs = mappM_ addErrTc err_msgs
 addErrTcM :: (TidyEnv, Message) -> TcM ()
 addErrTcM (tidy_env, err_msg)
   = do { ctxt <- getErrCtxt ;
-	 loc  <- getSrcLocM ;
+	 loc  <- getSrcSpanM ;
 	 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
@@ -632,7 +654,7 @@ warnTc warn_if_true warn_msg
 \begin{code}
 add_err_tcm tidy_env err_msg loc ctxt
  = do { ctxt_msgs <- do_ctxt tidy_env ctxt ;
-	addErrAt loc (vcat (err_msg : ctxt_to_use ctxt_msgs)) }
+	addLongErrAt loc err_msg (vcat (ctxt_to_use ctxt_msgs)) }
 
 do_ctxt tidy_env []
  = return []
@@ -647,7 +669,7 @@ ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
 
 %************************************************************************
 %*									*
-	     Other stuff specific to type checker
+	     Type constraints (the so-called LIE)
 %*									*
 %************************************************************************
 
@@ -682,14 +704,7 @@ extendLIEs insts
 	 writeMutVar lie_var (mkLIE insts `plusLIE` lie) }
 \end{code}
 
-
 \begin{code}
-getStage :: TcM Stage
-getStage = do { env <- getLclEnv; return (tcl_level env) }
-
-setStage :: Stage -> TcM a -> TcM a 
-setStage s = updLclEnv (\ env -> env { tcl_level = s })
-
 setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
 -- Set the local type envt, but do *not* disturb other fields,
 -- notably the lie_var
@@ -703,29 +718,179 @@ setLclTypeEnv lcl_env thing_inside
 
 %************************************************************************
 %*									*
-	     Stuff for the renamer's local env
+	     Template Haskell context
 %*									*
 %************************************************************************
 
 \begin{code}
-initRn :: RnMode -> RnM a -> TcRn m a
-initRn mode thing_inside
- = do { env <- getGblEnv ;
-	let { lcl_env = RnLclEnv {
-			     rn_mode = mode,
-			     rn_lenv = emptyRdrEnv }} ;
-	setLclEnv lcl_env thing_inside }
+getStage :: TcM ThStage
+getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
+
+setStage :: ThStage -> TcM a -> TcM a 
+setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
+\end{code}
+
+
+%************************************************************************
+%*									*
+	     Arrow context
+%*									*
+%************************************************************************
+
+\begin{code}
+popArrowBinders :: TcM a -> TcM a	-- Move to the left of a (-<); see comments in TcRnTypes
+popArrowBinders 
+  = updLclEnv (\ env -> env { tcl_arrow_ctxt = pop (tcl_arrow_ctxt env)  })
+  where
+    pop (ArrCtxt {proc_level = curr_lvl, proc_banned = banned})
+	= ASSERT( not (curr_lvl `elem` banned) )
+	  ArrCtxt {proc_level = curr_lvl, proc_banned = curr_lvl : banned}
+
+getBannedProcLevels :: TcM [ProcLevel]
+  = do { env <- getLclEnv; return (proc_banned (tcl_arrow_ctxt env)) }
+
+incProcLevel :: TcM a -> TcM a
+incProcLevel 
+  = updLclEnv (\ env -> env { tcl_arrow_ctxt = inc (tcl_arrow_ctxt env) })
+  where
+    inc ctxt = ctxt { proc_level = proc_level ctxt + 1 }
 \end{code}
 
+
+%************************************************************************
+%*									*
+	     Stuff for the renamer's local env
+%*									*
+%************************************************************************
+
 \begin{code}
 getLocalRdrEnv :: RnM LocalRdrEnv
-getLocalRdrEnv = do { env <- getLclEnv; return (rn_lenv env) }
+getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
 
 setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
 setLocalRdrEnv rdr_env thing_inside 
-  = updLclEnv (\env -> env {rn_lenv = rdr_env}) thing_inside
-
-getModeRn :: RnM RnMode
-getModeRn = do { env <- getLclEnv; return (rn_mode env) }
+  = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
 \end{code}
 
+
+%************************************************************************
+%*									*
+	     Stuff for interface decls
+%*									*
+%************************************************************************
+
+\begin{code}
+initIfaceTcRn :: IfG a -> TcRn a
+initIfaceTcRn thing_inside
+  = do  { tcg_env <- getGblEnv 
+	; let { if_env = IfGblEnv { 
+			if_rec_types = Just (tcg_mod tcg_env, get_type_env),
+			if_is_boot   = imp_dep_mods (tcg_imports tcg_env) }
+	      ; get_type_env = readMutVar (tcg_type_env_var tcg_env) }
+	; setEnvs (if_env, ()) thing_inside }
+
+initIfaceExtCore :: IfL a -> TcRn a
+initIfaceExtCore thing_inside
+  = do  { tcg_env <- getGblEnv 
+	; let { mod = tcg_mod tcg_env
+	      ; if_env = IfGblEnv { 
+			if_rec_types = Just (mod, return (tcg_type_env tcg_env)), 
+			if_is_boot   = imp_dep_mods (tcg_imports tcg_env) }
+	      ; if_lenv = IfLclEnv { if_mod     = moduleName mod,
+				     if_tv_env  = emptyOccEnv,
+				     if_id_env  = emptyOccEnv }
+	  }
+	; setEnvs (if_env, if_lenv) thing_inside }
+
+initIfaceCheck :: HscEnv -> IfG a -> IO a
+-- Used when checking the up-to-date-ness of the old Iface
+-- Initialise the environment with no useful info at all
+initIfaceCheck hsc_env do_this
+ = do	{ let { gbl_env = IfGblEnv { if_is_boot   = emptyModuleEnv,
+				     if_rec_types = Nothing } ;
+	   }
+	; initTcRnIf 'i' hsc_env gbl_env () do_this
+    }
+
+initIfaceTc :: HscEnv -> ModIface 
+ 	    -> (TcRef TypeEnv -> IfL a) -> IO a
+-- Used when type-checking checking an up-to-date interface file
+-- No type envt from the current module, but we do know the module dependencies
+initIfaceTc hsc_env iface do_this
+ = do	{ tc_env_var <- newIORef emptyTypeEnv
+	; let { gbl_env = IfGblEnv { if_is_boot   = mkModDeps (dep_mods (mi_deps iface)),
+				     if_rec_types = Just (mod, readMutVar tc_env_var) } ;
+	      ; if_lenv = IfLclEnv { if_mod     = moduleName mod,
+				     if_tv_env  = emptyOccEnv,
+				     if_id_env  = emptyOccEnv }
+	   }
+	; initTcRnIf 'i' hsc_env gbl_env if_lenv (do_this tc_env_var)
+    }
+  where
+    mod = mi_module iface
+
+initIfaceRules :: HscEnv -> ModGuts -> IfG a -> IO a
+-- Used when sucking in new Rules in SimplCore
+-- We have available the type envt of the module being compiled, and we must use it
+initIfaceRules hsc_env guts do_this
+ = do	{ let {
+	     is_boot = mkModDeps (dep_mods (mg_deps guts))
+			-- Urgh!  But we do somehow need to get the info
+			-- on whether (for this particular compilation) we should
+			-- import a hi-boot file or not.
+	   ; type_info = (mg_module guts, return (mg_types guts))
+	   ; gbl_env = IfGblEnv { if_is_boot   = is_boot,
+				  if_rec_types = Just type_info } ;
+	   }
+
+	-- Run the thing; any exceptions just bubble out from here
+	; initTcRnIf 'i' hsc_env gbl_env () do_this
+    }
+
+initIfaceLcl :: ModuleName -> IfL a -> IfM lcl a
+initIfaceLcl mod thing_inside 
+  = setLclEnv (IfLclEnv { if_mod      = mod,
+			   if_tv_env  = emptyOccEnv,
+			   if_id_env  = emptyOccEnv })
+	      thing_inside
+
+
+--------------------
+forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
+-- Run thing_inside in an interleaved thread.  
+-- It shares everything with the parent thread, so this is DANGEROUS.  
+--
+-- It returns Nothing if the computation fails
+-- 
+-- It's used for lazily type-checking interface
+-- signatures, which is pretty benign
+
+forkM_maybe doc thing_inside
+ = do {	unsafeInterleaveM $
+	do { traceIf (text "Starting fork {" <+> doc)
+	   ; mb_res <- tryM thing_inside ;
+	     case mb_res of
+		Right r  -> do	{ traceIf (text "} ending fork" <+> doc)
+				; return (Just r) }
+		Left exn -> do {
+
+		    -- Bleat about errors in the forked thread, if -ddump-if-trace is on
+		    -- Otherwise we silently discard errors. Errors can legitimately
+		    -- happen when compiling interface signatures (see tcInterfaceSigs)
+		      ifOptM Opt_D_dump_if_trace 
+			     (print_errs (hang (text "forkM failed:" <+> doc)
+				             4 (text (show exn))))
+
+		    ; traceIf (text "} ending fork (badly)" <+> doc)
+	  	    ; return Nothing }
+	}}
+  where
+    print_errs sdoc = ioToIOEnv (printErrs (sdoc defaultErrStyle))
+
+forkM :: SDoc -> IfL a -> IfL a
+forkM doc thing_inside
+ = do	{ mb_res <- forkM_maybe doc thing_inside
+	; return (case mb_res of 
+			Nothing -> pprPanic "forkM" doc
+			Just r  -> r) }
+\end{code}