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 (file)
--- 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,
        Messages, errorsFound, emptyMessages,
        mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
        printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,

-       warnIsErrorMsg,
+       warnIsErrorMsg, mkLongWarnMsg,

 
        ghcExit,
        doIfSet, doIfSet_dyn, 
 
        ghcExit,
        doIfSet, doIfSet_dyn, 

@@ -105,6 +105,9 @@ mkLongErrMsg locn print_unqual msg extra
 mkWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> WarnMsg
 mkWarnMsg = mkErrMsg
 
 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
 -- 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 (file)
--- 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
 
             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 ;
   = 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 ()
         (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 :: 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 :: 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
 
 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 ;
 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
 
 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 (file)
--- 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)
                  ; 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
 
   qLocation = do { m <- getModule
                 ; l <- getSrcSpanM