X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnMonad.lhs;h=350aca0876b3297837b4774a21c6fc50469196f1;hp=39313ec1d5468e8cd25c4c7809de7a8967e4a020;hb=29da2cf3011c292bc4261601aff85afb13e24d54;hpb=433d69e5f54d14ab15e5bcb1abe1ea94517e8d9a

diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs
index 39313ec..350aca0 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, mkLocMessage )
+			  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)
 
@@ -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 }
@@ -398,10 +398,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) }
 
@@ -651,7 +654,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 []