Fix Trac #1814 (staging interaction in Template Haskell and GHCi), and add comments

[ghc-hetmet.git] / compiler / typecheck / TcRnMonad.lhs

diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 3c1f510..f118f47 100644 (file)
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -3,6 +3,13 @@
 %
 
 \begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module TcRnMonad(
        module TcRnMonad,
        module TcRnTypes,
@@ -23,6 +30,7 @@ import TcType
 import InstEnv
 import FamInstEnv
 
+import Coercion
 import Var
 import Id
 import VarSet
@@ -36,6 +44,7 @@ import Bag
 import Outputable
 import UniqSupply
 import Unique
+import UniqFM
 import DynFlags
 import StaticFlags
 import FastString
@@ -113,7 +122,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                tcg_dfun_n   = dfun_n_var,
                tcg_keep     = keep_var,
                tcg_doc      = Nothing,
-               tcg_hmi      = HaddockModInfo Nothing Nothing Nothing Nothing
+               tcg_hmi      = HaddockModInfo Nothing Nothing Nothing Nothing,
+                tcg_hpc      = False
             } ;
             lcl_env = TcLclEnv {
                tcl_errs       = errs_var,
@@ -176,7 +186,7 @@ initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside
        ; let { env = Env { env_top = hsc_env,
                            env_us  = us_var,
                            env_gbl = gbl_env,
-                           env_lcl = lcl_env } }
+                           env_lcl = lcl_env} }
 
        ; runIOEnv env thing_inside
        }
@@ -360,7 +370,8 @@ traceOptTcRn flag doc = ifOptM flag $ do
 
 dumpTcRn :: SDoc -> TcRn ()
 dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ;
-                   ioToTcRn (printForUser stderr (mkPrintUnqualified rdr_env) doc) }
+                    dflags <- getDOpts ;
+                   ioToTcRn (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) }
 
 dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
 dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
@@ -466,7 +477,8 @@ addLongErrAt loc msg extra
   = do { traceTc (ptext SLIT("Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ; 
         errs_var <- getErrsVar ;
         rdr_env <- getGlobalRdrEnv ;
-        let { err = mkLongErrMsg loc (mkPrintUnqualified rdr_env) msg extra } ;
+         dflags <- getDOpts ;
+        let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ;
         (warns, errs) <- readMutVar errs_var ;
         writeMutVar errs_var (warns, errs `snocBag` err) }
 
@@ -482,7 +494,8 @@ addReportAt :: SrcSpan -> Message -> TcRn ()
 addReportAt loc msg
   = do { errs_var <- getErrsVar ;
         rdr_env <- getGlobalRdrEnv ;
-        let { warn = mkWarnMsg loc (mkPrintUnqualified rdr_env) msg } ;
+         dflags <- getDOpts ;
+        let { warn = mkWarnMsg loc (mkPrintUnqualified dflags rdr_env) msg } ;
         (warns, errs) <- readMutVar errs_var ;
         writeMutVar errs_var (warns `snocBag` warn, errs) }
 
@@ -862,9 +875,11 @@ setLclTypeEnv lcl_env thing_inside
 recordThUse :: TcM ()
 recordThUse = do { env <- getGblEnv; writeMutVar (tcg_th_used env) True }
 
-keepAliveTc :: Name -> TcM ()          -- Record the name in the keep-alive set
-keepAliveTc n = do { env <- getGblEnv; 
-                  ; updMutVar (tcg_keep env) (`addOneToNameSet` n) }
+keepAliveTc :: Id -> TcM ()    -- Record the name in the keep-alive set
+keepAliveTc id 
+  | isLocalId id = do { env <- getGblEnv; 
+                     ; updMutVar (tcg_keep env) (`addOneToNameSet` idName id) }
+  | otherwise = return ()
 
 keepAliveSetTc :: NameSet -> TcM ()    -- Record the name in the keep-alive set
 keepAliveSetTc ns = do { env <- getGblEnv; 
@@ -904,8 +919,8 @@ setLocalRdrEnv rdr_env thing_inside
 mkIfLclEnv :: Module -> SDoc -> IfLclEnv
 mkIfLclEnv mod loc = IfLclEnv { if_mod     = mod,
                                if_loc     = loc,
-                               if_tv_env  = emptyOccEnv,
-                               if_id_env  = emptyOccEnv }
+                               if_tv_env  = emptyUFM,
+                               if_id_env  = emptyUFM }
 
 initIfaceTcRn :: IfG a -> TcRn a
 initIfaceTcRn thing_inside
@@ -1021,5 +1036,3 @@ forkM doc thing_inside
                                   -- pprPanic "forkM" doc
                        Just r  -> r) }
 \end{code}
-
-