From: Thomas Schilling <nominolo@googlemail.com>
Date: Tue, 15 Sep 2009 15:03:53 +0000 (+0000)
Subject: Put context information for warnings in errMsgExtraInfo.
X-Git-Tag: 2009-11-15~316
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=ee2571bd2a80683d33cf65a01942bc8be50a5e33

Put context information for warnings in errMsgExtraInfo.

For type checker warnings, the context information ("In the expression
...") was simply appended to the main message while for proper errors
they live in errMsgExtraInfo.  This allows GHC API clients to drop
that information if not needed.
---

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index dd7f2ac..f406c33 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -13,7 +13,7 @@ module ErrUtils (
 	Messages, errorsFound, emptyMessages,
 	mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
 	printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
-	warnIsErrorMsg,
+	warnIsErrorMsg, mkLongWarnMsg,
 
 	ghcExit,
 	doIfSet, doIfSet_dyn, 
@@ -105,6 +105,9 @@ mkLongErrMsg locn print_unqual msg extra
 mkWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> WarnMsg
 mkWarnMsg = mkErrMsg
 
+mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> Message -> ErrMsg
+mkLongWarnMsg = mkLongErrMsg
+
 -- Variant that doesn't care about qualified/unqualified names
 mkPlainWarnMsg :: SrcSpan -> Message -> ErrMsg
 mkPlainWarnMsg locn msg = mkWarnMsg locn alwaysQualify msg
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 06185be..ad74133 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -489,26 +489,27 @@ addErrs msgs = mapM_ add msgs
 	     where
 	       add (loc,msg) = addErrAt loc msg
 
-addReport :: Message -> TcRn ()
-addReport msg = do loc <- getSrcSpanM; addReportAt loc msg
+addReport :: Message -> Message -> TcRn ()
+addReport msg extra_info = do loc <- getSrcSpanM; addReportAt loc msg extra_info
 
-addReportAt :: SrcSpan -> Message -> TcRn ()
-addReportAt loc msg
+addReportAt :: SrcSpan -> Message -> Message -> TcRn ()
+addReportAt loc msg extra_info
   = do { errs_var <- getErrsVar ;
 	 rdr_env <- getGlobalRdrEnv ;
          dflags <- getDOpts ;
-	 let { warn = mkWarnMsg loc (mkPrintUnqualified dflags rdr_env) msg } ;
+	 let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env)
+	                            msg extra_info } ;
 	 (warns, errs) <- readMutVar errs_var ;
   	 writeMutVar errs_var (warns `snocBag` warn, errs) }
 
 addWarn :: Message -> TcRn ()
-addWarn msg = addReport (ptext (sLit "Warning:") <+> msg)
+addWarn msg = addReport (ptext (sLit "Warning:") <+> msg) empty
 
 addWarnAt :: SrcSpan -> Message -> TcRn ()
-addWarnAt loc msg = addReportAt loc (ptext (sLit "Warning:") <+> msg)
+addWarnAt loc msg = addReportAt loc (ptext (sLit "Warning:") <+> msg) empty
 
 addLocWarn :: Located e -> (e -> Message) -> TcRn ()
-addLocWarn (L loc e) fn = addReportAt loc (fn e)
+addLocWarn (L loc e) fn = addReportAt loc (fn e) empty
 
 checkErr :: Bool -> Message -> TcRn ()
 -- Add the error if the bool is False
@@ -765,7 +766,7 @@ addWarnTcM :: (TidyEnv, Message) -> TcM ()
 addWarnTcM (env0, msg)
  = do { ctxt <- getErrCtxt ;
 	err_info <- mkErrInfo env0 ctxt ;
-	addReport (vcat [ptext (sLit "Warning:") <+> msg, err_info]) }
+	addReport (ptext (sLit "Warning:") <+> msg) err_info }
 
 warnTc :: Bool -> Message -> TcM ()
 warnTc warn_if_true warn_msg
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index ed025ae..f5c3ab8 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -821,7 +821,7 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
 		  ; return (TH.mkNameU s i) }
 
   qReport True msg  = addErr (text msg)
-  qReport False msg = addReport (text msg)
+  qReport False msg = addReport (text msg) empty
 
   qLocation = do { m <- getModule
 		 ; l <- getSrcSpanM