X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnMonad.lhs;h=86af49a59d4b2339fb31eff3c05baf786cea8999;hb=f23d940ee5d97f4395bf4f4c87a5b4a6a30af9d8;hp=52cb3a74250ee4cbb6f722460589279acf7d9a88;hpb=550421384b8364cdaf3135f7859c9f7d7ee1fff1;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs
index 52cb3a7..86af49a 100644
--- a/ghc/compiler/typecheck/TcRnMonad.lhs
+++ b/ghc/compiler/typecheck/TcRnMonad.lhs
@@ -27,7 +27,8 @@ import InstEnv		( InstEnv, emptyInstEnv, extendInstEnv )
 import VarSet		( emptyVarSet )
 import VarEnv		( TidyEnv, emptyTidyEnv )
 import ErrUtils		( Message, Messages, emptyMessages, errorsFound, 
-			  mkErrMsg, mkWarnMsg, printErrorsAndWarnings )
+			  mkErrMsg, mkWarnMsg, printErrorsAndWarnings,
+			  mkLocMessage, mkLongErrMsg )
 import SrcLoc		( mkGeneralSrcSpan, SrcSpan, Located(..) )
 import NameEnv		( emptyNameEnv )
 import NameSet		( emptyDUs, emptyNameSet )
@@ -64,7 +65,7 @@ ioToTcRn = ioToIOEnv
 initTc :: HscEnv
        -> Module 
        -> TcM r
-       -> IO (Maybe r)
+       -> IO (Messages, Maybe r)
 		-- Nothing => error thrown by the thing inside
 		-- (error messages should have been printed already)
 
@@ -84,7 +85,7 @@ initTc hsc_env mod do_this
 		tcg_type_env_var = type_env_var,
 		tcg_inst_env  = mkImpInstEnv hsc_env,
 		tcg_inst_uses = dfuns_var,
-		tcg_exports  = [],
+		tcg_exports  = emptyNameSet,
 		tcg_imports  = init_imports,
 		tcg_dus      = emptyDUs,
 		tcg_binds    = emptyBag,
@@ -114,15 +115,14 @@ initTc hsc_env mod do_this
 				    Right res -> return (Just res)
 				    Left _    -> return Nothing } ;
 
-	-- Print any error messages
+	-- Collect any error messages
 	msgs <- readIORef errs_var ;
-	printErrorsAndWarnings msgs ;
 
 	let { dflags = hsc_dflags hsc_env
 	    ; final_res | errorsFound dflags msgs = Nothing
 			| otherwise	   	  = maybe_res } ;
 
-	return final_res
+	return (msgs, final_res)
     }
   where
     init_imports = emptyImportAvails { imp_qual = unitModuleEnv mod emptyAvailEnv }
@@ -131,6 +131,16 @@ initTc hsc_env mod do_this
 	-- list, and there are no bindings in M, we don't bleat 
 	-- "unknown module M".
 
+initTcPrintErrors
+       :: HscEnv
+       -> Module 
+       -> TcM r
+       -> IO (Maybe r)
+initTcPrintErrors env mod todo = do
+  (msgs, res) <- initTc env mod todo
+  printErrorsAndWarnings msgs
+  return res
+
 mkImpInstEnv :: HscEnv -> InstEnv
 -- At the moment we (wrongly) build an instance environment from all the
 -- home-package modules we have already compiled.
@@ -309,7 +319,12 @@ dumpOptIf flag doc = ifOptM flag $
 		     ioToIOEnv (printForUser stderr alwaysQualify doc)
 
 dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
-dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
+dumpOptTcRn flag doc = ifOptM flag $ do
+			{ ctxt <- getErrCtxt
+			; loc  <- getSrcSpanM
+			; ctxt_msgs <- do_ctxt emptyTidyEnv ctxt 
+			; let real_doc = mkLocMessage loc (vcat (doc : ctxt_to_use ctxt_msgs))
+			; dumpTcRn real_doc }
 
 dumpTcRn :: SDoc -> TcRn ()
 dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ;
@@ -393,10 +408,13 @@ addLocErr :: Located e -> (e -> Message) -> TcRn ()
 addLocErr (L loc e) fn = addErrAt loc (fn e)
 
 addErrAt :: SrcSpan -> Message -> TcRn ()
-addErrAt loc msg
+addErrAt loc msg = addLongErrAt loc msg empty
+
+addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
+addLongErrAt loc msg extra
  = do {  errs_var <- getErrsVar ;
 	 rdr_env <- getGlobalRdrEnv ;
-	 let { err = mkErrMsg loc (unQualInScope rdr_env) msg } ;
+	 let { err = mkLongErrMsg loc (unQualInScope rdr_env) msg extra } ;
 	 (warns, errs) <- readMutVar errs_var ;
   	 writeMutVar errs_var (warns, errs `snocBag` err) }
 
@@ -646,7 +664,7 @@ warnTc warn_if_true warn_msg
 \begin{code}
 add_err_tcm tidy_env err_msg loc ctxt
  = do { ctxt_msgs <- do_ctxt tidy_env ctxt ;
-	addErrAt loc (vcat (err_msg : ctxt_to_use ctxt_msgs)) }
+	addLongErrAt loc err_msg (vcat (ctxt_to_use ctxt_msgs)) }
 
 do_ctxt tidy_env []
  = return []