X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnMonad.lhs;h=835752e0e0b21a29f700dc1daa1c5194291b8d3a;hb=e393bb3a7dd22fc27e753af3f18356790e65f73c;hp=03e2186f0eb4b8172cc2a724e387029589617b8d;hpb=e6d004928bcd0e71ba58c034b6fe4c870e6a70cb;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs
index 03e2186..835752e 100644
--- a/ghc/compiler/typecheck/TcRnMonad.lhs
+++ b/ghc/compiler/typecheck/TcRnMonad.lhs
@@ -150,11 +150,12 @@ initTc  (HscEnv { hsc_mode   = ghci_mode,
 		tcg_fords    = [] } ;
 
 	     lcl_env = TcLclEnv {
-		tcl_ctxt   = [],
-		tcl_level  = topStage,
-		tcl_env    = emptyNameEnv,
-		tcl_tyvars = tvs_var,
-		tcl_lie	   = panic "initTc:LIE" } ;
+		tcl_ctxt       = [],
+		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
 	     } ;
    
@@ -246,8 +247,15 @@ 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
 
 \begin{code}
@@ -677,7 +685,7 @@ ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
 
 %************************************************************************
 %*									*
-	     Other stuff specific to type checker
+	     Type constraints (the so-called LIE)
 %*									*
 %************************************************************************
 
@@ -712,14 +720,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
@@ -733,6 +734,47 @@ setLclTypeEnv lcl_env thing_inside
 
 %************************************************************************
 %*									*
+	     Template Haskell context
+%*									*
+%************************************************************************
+
+\begin{code}
+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
 %*									*
 %************************************************************************
@@ -740,8 +782,7 @@ setLclTypeEnv lcl_env thing_inside
 \begin{code}
 initRn :: RnMode -> RnM a -> TcRn m a
 initRn mode thing_inside
- = do { env <- getGblEnv ;
-	let { lcl_env = RnLclEnv {
+ = do { let { lcl_env = RnLclEnv {
 			     rn_mode = mode,
 			     rn_lenv = emptyRdrEnv }} ;
 	setLclEnv lcl_env thing_inside }