X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnMonad.lhs;h=8f8a6df396f28fd1bb43e271d8c9241ee54d3f2e;hb=1f5e55804b97d2b9a77207d568d602ba88d8855d;hp=5dce531ac1d2017642aae101cfe964fac1cb2ab6;hpb=98688c6e8fd33f31c51218cf93cbf03fe3a5e73d;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs
index 5dce531..8f8a6df 100644
--- 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,
@@ -38,7 +38,7 @@ import Bag		( emptyBag )
 import Outputable
 import UniqSupply	( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply )
 import Unique		( Unique )
-import CmdLineOpts	( DynFlags, DynFlag(..), dopt, opt_PprStyle_Debug )
+import CmdLineOpts	( DynFlags, DynFlag(..), dopt, opt_PprStyle_Debug, dopt_set )
 import Bag		( snocBag, unionBags )
 import Panic		( showException )
  
@@ -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,
@@ -225,6 +226,10 @@ getDOpts = do { env <- getTopEnv; return (hsc_dflags env) }
 doptM :: DynFlag -> TcRnIf gbl lcl Bool
 doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) }
 
+setOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+setOptM flag = updEnv (\ env@(Env { env_top = top }) ->
+			 env { env_top = top { hsc_dflags = dopt_set (hsc_dflags top) flag}} )
+
 ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()	-- Do it flag is true
 ifOptM flag thing_inside = do { b <- doptM flag; 
 				if b then thing_inside else return () }
@@ -380,8 +385,8 @@ addErrs msgs = mappM_ add msgs
 	     where
 	       add (loc,msg) = addErrAt loc msg
 
-addWarn :: Message -> TcRn ()
-addWarn msg
+addReport :: Message -> TcRn ()
+addReport msg
   = do { errs_var <- getErrsVar ;
 	 loc <- getSrcLocM ;
 	 rdr_env <- getGlobalRdrEnv ;
@@ -389,6 +394,9 @@ addWarn msg
 	 (warns, errs) <- readMutVar errs_var ;
   	 writeMutVar errs_var (warns `snocBag` warn, errs) }
 
+addWarn :: Message -> TcRn ()
+addWarn msg = addReport (ptext SLIT("Warning:") <+> msg)
+
 checkErr :: Bool -> Message -> TcRn ()
 -- Add the error if the bool is False
 checkErr ok msg = checkM ok (addErr msg)
@@ -403,6 +411,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 +766,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