[project @ 2003-11-06 17:09:50 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 b3bd086..8f8a6df 100644 (file)
--- a/ghc/compiler/typecheck/TcRnMonad.lhs
+++ b/ghc/compiler/typecheck/TcRnMonad.lhs
@@ -12,7 +12,7 @@ import IOEnv          -- Re-export all
 
 import HsSyn           ( MonoBinds(..) )
 import HscTypes                ( HscEnv(..), ModGuts(..), ModIface(..),
-                         TyThing, Dependencies(..),
+                         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}
 
 
@@ -754,15 +776,22 @@ initIfaceCheck hsc_env do_this
        ; initTcRnIf 'i' hsc_env gbl_env () do_this
     }
 
-initIfaceTc :: HscEnv -> ModIface -> IfG a -> IO a
+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  { let { gbl_env = IfGblEnv { if_is_boot   = mkModDeps (dep_mods (mi_deps iface)),
-                                    if_rec_types = Nothing } ;
+ = 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 () do_this
+       ; 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