[project @ 2003-06-25 08:17:24 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 a9746a7..835752e 100644 (file)
--- a/ghc/compiler/typecheck/TcRnMonad.lhs
+++ b/ghc/compiler/typecheck/TcRnMonad.lhs
@@ -116,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,
@@ -139,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,
@@ -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
             } ;
    
@@ -189,6 +190,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)
@@ -240,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}
@@ -470,6 +484,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
@@ -481,7 +496,8 @@ 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 {
@@ -669,7 +685,7 @@ ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
 
 %************************************************************************
 %*                                                                     *
-            Other stuff specific to type checker
+            Type constraints (the so-called LIE)
 %*                                                                     *
 %************************************************************************
 
@@ -704,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
@@ -725,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
 %*                                                                     *
 %************************************************************************
@@ -732,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 }