[project @ 2005-04-28 10:09:41 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 aeca508..41e1133 100644 (file)
--- 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,23 +63,26 @@ 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 ;
        dfuns_var    <- newIORef emptyNameSet ;
        keep_var     <- newIORef emptyNameSet ;
        th_var       <- newIORef False ;
+       dfun_n_var   <- newIORef 1 ;
 
        let {
             gbl_env = TcGblEnv {
                tcg_mod      = mod,
+               tcg_src      = hsc_src,
                tcg_rdr_env  = emptyGlobalRdrEnv,
                tcg_fix_env  = emptyNameEnv,
                tcg_default  = Nothing,
@@ -90,11 +94,13 @@ initTc hsc_env mod do_this
                tcg_exports  = emptyNameSet,
                tcg_imports  = init_imports,
                tcg_dus      = emptyDUs,
+               tcg_rn_decls = Nothing,
                tcg_binds    = emptyLHsBinds,
                tcg_deprecs  = NoDeprecs,
                tcg_insts    = [],
                tcg_rules    = [],
                tcg_fords    = [],
+               tcg_dfun_n   = dfun_n_var,
                tcg_keep     = keep_var
             } ;
             lcl_env = TcLclEnv {
@@ -103,7 +109,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 +139,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 +241,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 +352,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) }
 
@@ -708,6 +716,13 @@ debugTc thing = return ()
 %************************************************************************
 
 \begin{code}
+nextDFunIndex :: TcM Int       -- Get the next dfun index
+nextDFunIndex = do { env <- getGblEnv
+                  ; let dfun_n_var = tcg_dfun_n env
+                  ; n <- readMutVar dfun_n_var
+                  ; writeMutVar dfun_n_var (n+1)
+                  ; return n }
+
 getLIEVar :: TcM (TcRef LIE)
 getLIEVar = do { env <- getLclEnv; return (tcl_lie env) }
 
@@ -778,32 +793,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
 %*                                                                     *
 %************************************************************************
@@ -857,16 +846,16 @@ initIfaceCheck hsc_env do_this
        ; initTcRnIf 'i' hsc_env gbl_env () do_this
     }
 
-initIfaceTc :: HscEnv -> ModIface 
-           -> (TcRef TypeEnv -> IfL a) -> IO a
+initIfaceTc :: ModIface 
+           -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl 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
+initIfaceTc iface do_this
+ = do  { tc_env_var <- newMutVar emptyTypeEnv
        ; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readMutVar tc_env_var) } ;
              ; if_lenv = mkIfLclEnv mod doc
           }
-       ; initTcRnIf 'i' hsc_env gbl_env if_lenv (do_this tc_env_var)
+       ; setEnvs (gbl_env, if_lenv) (do_this tc_env_var)
     }
   where
     mod = mi_module iface