[project @ 2003-10-29 18:14:27 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 5dce531..47cd402 100644 (file)
--- a/ghc/compiler/typecheck/TcRnMonad.lhs
+++ b/ghc/compiler/typecheck/TcRnMonad.lhs
@@ -11,8 +11,8 @@ import TcRnTypes      -- Re-export all
 import IOEnv           -- Re-export all
 
 import HsSyn           ( MonoBinds(..) )
-import HscTypes                ( HscEnv(..), 
-                         TyThing,
+import HscTypes                ( HscEnv(..), ModGuts(..), ModIface(..),
+                         TyThing, Dependencies(..), TypeEnv, emptyTypeEnv,
                          ExternalPackageState(..), HomePackageTable,
                          ModDetails(..), HomeModInfo(..), 
                          Deprecs(..), FixityEnv, FixItem,
@@ -92,7 +92,8 @@ initTc hsc_env mod do_this
                tcg_deprecs  = NoDeprecs,
                tcg_insts    = [],
                tcg_rules    = [],
-               tcg_fords    = []
+               tcg_fords    = [],
+               tcg_keep     = emptyNameSet
             } ;
             lcl_env = TcLclEnv {
                tcl_errs       = errs_var,
@@ -403,6 +404,20 @@ addMessages (m_warns, m_errs)
         (warns, errs) <- readMutVar errs_var ;
         writeMutVar errs_var (warns `unionBags` m_warns,
                               errs  `unionBags` m_errs) }
+
+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}
 
 
@@ -744,11 +759,45 @@ initIfaceExtCore thing_inside
          }
        ; setEnvs (if_env, if_lenv) thing_inside }
 
-initIfaceIO :: HscEnv -> IfG a -> IO a
-initIfaceIO hsc_env do_this
+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 {
-            gbl_env = IfGblEnv { if_is_boot   = emptyModuleEnv,        -- Bogus?
-                                 if_rec_types = Nothing } ;
+            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