X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnMonad.lhs;h=ed1dce663a7a69ec3c69fd3928fec89fd501a701;hb=19b44dcc5e5b9f92735fa99aa45dfaa94777177c;hp=f36be69fa8f671f1936b7c878203941a599545a1;hpb=c1681a73fa4ca4cf8758264ae387ac09a9e900d8;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index f36be69..ed1dce6 100644
--- 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
@@ -177,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
 	}
@@ -361,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)
@@ -387,6 +397,9 @@ tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }
 getGlobalRdrEnv :: TcRn GlobalRdrEnv
 getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
 
+getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
+getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }
+
 getImports :: TcRn ImportAvails
 getImports = do { env <- getGblEnv; return (tcg_imports env) }
 
@@ -467,7 +480,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) }
 
@@ -483,7 +497,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) }
 
@@ -549,6 +564,19 @@ recoverM recover thing
 	   Left exn  -> recover
 	   Right res -> returnM res }
 
+
+-----------------------
+mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
+-- Drop elements of the input that fail, so the result
+-- list can be shorter than the argument list
+mapAndRecoverM f []     = return []
+mapAndRecoverM f (x:xs) = do { mb_r <- tryM (f x)
+			     ; rs <- mapAndRecoverM f xs
+			     ; return (case mb_r of
+					  Left _  -> rs
+					  Right r -> r:rs) }
+			
+
 -----------------------
 tryTc :: TcRn a -> TcRn (Messages, Maybe a)
 -- (tryTc m) executes m, and returns
@@ -863,9 +891,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; 
@@ -905,8 +935,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
@@ -1022,5 +1052,3 @@ forkM doc thing_inside
 				   -- pprPanic "forkM" doc
 			Just r  -> r) }
 \end{code}
-
-