X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnMonad.lhs;h=6ff9043dfb9aaa241d4dd231be6eda2549d96023;hb=872f7e822cb83692afa808509b4f2a6b4343fb2c;hp=aeca50874424102edcac31a62f858eebb53bc42b;hpb=ac80e0dececb68ed6385e3b34765fd8f9c019767;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs
index aeca508..6ff9043 100644
--- a/ghc/compiler/typecheck/TcRnMonad.lhs
+++ b/ghc/compiler/typecheck/TcRnMonad.lhs
@@ -12,10 +12,10 @@ import IOEnv		-- Re-export all
 
 import HsSyn		( emptyLHsBinds )
 import HscTypes		( HscEnv(..), ModGuts(..), ModIface(..),
-			  TyThing, TypeEnv, emptyTypeEnv,
+			  TyThing, TypeEnv, emptyTypeEnv, HscSource(..), isHsBoot,
 			  ExternalPackageState(..), HomePackageTable,
-			  Deprecs(..), FixityEnv, FixItem,
-			  GhciMode, lookupType, unQualInScope )
+			  Deprecs(..), FixityEnv, FixItem, 
+			  lookupType, unQualInScope )
 import Module		( Module, unitModuleEnv )
 import RdrName		( GlobalRdrEnv, emptyGlobalRdrEnv, 	
 			  LocalRdrEnv, emptyLocalRdrEnv )
@@ -37,7 +37,8 @@ import Bag		( emptyBag )
 import Outputable
 import UniqSupply	( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply )
 import Unique		( Unique )
-import CmdLineOpts	( DynFlags, DynFlag(..), dopt, opt_PprStyle_Debug, dopt_set )
+import DynFlags		( DynFlags(..), DynFlag(..), dopt, dopt_set, GhcMode )
+import StaticFlags	( opt_PprStyle_Debug )
 import Bag		( snocBag, unionBags )
 import Panic		( showException )
  
@@ -62,13 +63,14 @@ ioToTcRn = ioToIOEnv
 
 \begin{code}
 initTc :: HscEnv
+       -> HscSource
        -> Module 
        -> TcM r
        -> IO (Messages, Maybe r)
 		-- Nothing => error thrown by the thing inside
 		-- (error messages should have been printed already)
 
-initTc hsc_env mod do_this
+initTc hsc_env hsc_src mod do_this
  = do { errs_var     <- newIORef (emptyBag, emptyBag) ;
       	tvs_var      <- newIORef emptyVarSet ;
 	type_env_var <- newIORef emptyNameEnv ;
@@ -79,6 +81,7 @@ initTc hsc_env mod do_this
       	let {
 	     gbl_env = TcGblEnv {
 		tcg_mod      = mod,
+		tcg_src	     = hsc_src,
 		tcg_rdr_env  = emptyGlobalRdrEnv,
 		tcg_fix_env  = emptyNameEnv,
 		tcg_default  = Nothing,
@@ -103,7 +106,6 @@ initTc hsc_env mod do_this
 		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
@@ -134,13 +136,13 @@ initTc hsc_env mod do_this
 	-- list, and there are no bindings in M, we don't bleat 
 	-- "unknown module M".
 
-initTcPrintErrors
+initTcPrintErrors	-- Used from the interactive loop only
        :: HscEnv
        -> Module 
        -> TcM r
        -> IO (Maybe r)
 initTcPrintErrors env mod todo = do
-  (msgs, res) <- initTc env mod todo
+  (msgs, res) <- initTc env HsSrcFile mod todo
   printErrorsAndWarnings msgs
   return res
 
@@ -236,8 +238,8 @@ ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()	-- Do it flag is tru
 ifOptM flag thing_inside = do { b <- doptM flag; 
 				if b then thing_inside else return () }
 
-getGhciMode :: TcRnIf gbl lcl GhciMode
-getGhciMode = do { env <- getTopEnv; return (hsc_mode env) }
+getGhciMode :: TcRnIf gbl lcl GhcMode
+getGhciMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
 \end{code}
 
 \begin{code}
@@ -347,6 +349,9 @@ dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ;
 getModule :: TcRn Module
 getModule = do { env <- getGblEnv; return (tcg_mod env) }
 
+tcIsHsBoot :: TcRn Bool
+tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }
+
 getGlobalRdrEnv :: TcRn GlobalRdrEnv
 getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
 
@@ -778,32 +783,6 @@ setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
 
 %************************************************************************
 %*									*
-	     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
 %*									*
 %************************************************************************