[commit: ghc] master: Make TcRnMonad.reportWarning call makeIntoWarning (dfe62eb)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/dfe62eb05feab7ec4acb31bcd12fb68028eebcda/ghc

>---------------------------------------------------------------

commit dfe62eb05feab7ec4acb31bcd12fb68028eebcda
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Jan 9 09:47:57 2015 +0000

    Make TcRnMonad.reportWarning call makeIntoWarning
    
    Previously the caller had do to that, and sometimes forgot


>---------------------------------------------------------------

dfe62eb05feab7ec4acb31bcd12fb68028eebcda
 compiler/typecheck/TcBinds.hs                         |  2 +-
 compiler/typecheck/TcErrors.hs                        |  8 ++++----
 compiler/typecheck/TcRnMonad.hs                       | 15 ++++++++++-----
 testsuite/tests/typecheck/should_compile/T9939.stderr |  8 ++++----
 testsuite/tests/typecheck/should_compile/tc056.stderr |  2 +-
 5 files changed, 20 insertions(+), 15 deletions(-)

diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 7d66d16..50bc62d 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -751,7 +751,7 @@ completeTheta inferred_theta
        ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures
        ; msg <- mkLongErrAt loc (mk_msg inferred_diff partial_sigs) empty
        ; case partial_sigs of
-           True | warn_partial_sigs -> reportWarning $ makeIntoWarning msg
+           True | warn_partial_sigs -> reportWarning msg
                 | otherwise         -> return ()
            False                    -> reportError msg
        ; return final_theta }
diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
index 21adab4..31772a2 100644
--- a/compiler/typecheck/TcErrors.hs
+++ b/compiler/typecheck/TcErrors.hs
@@ -32,7 +32,7 @@ import VarSet
 import VarEnv
 import NameEnv
 import Bag
-import ErrUtils         ( ErrMsg, makeIntoWarning, pprLocErrMsg )
+import ErrUtils         ( ErrMsg, pprLocErrMsg )
 import BasicTypes
 import Util
 import FastString
@@ -418,7 +418,7 @@ maybeReportHoleError ctxt ct err
     -- only if -fwarn_partial_type_signatures is on
     case cec_type_holes ctxt of
        HoleError -> reportError err
-       HoleWarn  -> reportWarning (makeIntoWarning err)
+       HoleWarn  -> reportWarning err
        HoleDefer -> return ()
 
   -- Otherwise this is a typed hole in an expression
@@ -426,7 +426,7 @@ maybeReportHoleError ctxt ct err
   = -- If deferring, report a warning only if -fwarn-typed-holds is on
     case cec_expr_holes ctxt of
        HoleError -> reportError err
-       HoleWarn  -> reportWarning (makeIntoWarning err)
+       HoleWarn  -> reportWarning err
        HoleDefer -> return ()
 
 maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM ()
@@ -434,7 +434,7 @@ maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM ()
 maybeReportError ctxt err
   -- See Note [Always warn with -fdefer-type-errors]
   | cec_defer_type_errors ctxt
-  = reportWarning (makeIntoWarning err)
+  = reportWarning err
   | cec_suppress ctxt
   = return ()
   | otherwise
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index 0f98726..b7038ec 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -753,11 +753,16 @@ reportError err
          writeTcRef errs_var (warns, errs `snocBag` err) }
 
 reportWarning :: ErrMsg -> TcRn ()
-reportWarning warn
-  = do { traceTc "Adding warning:" (pprLocErrMsg warn) ;
-         errs_var <- getErrsVar ;
-         (warns, errs) <- readTcRef errs_var ;
-         writeTcRef errs_var (warns `snocBag` warn, errs) }
+reportWarning err
+  = do { let warn = makeIntoWarning err
+                    -- 'err' was build by mkLongErrMsg or something like that,
+                    -- so it's of error severity.  For a warning we downgrade
+                    -- its severity to SevWarning
+
+       ; traceTc "Adding warning:" (pprLocErrMsg warn)
+       ; errs_var <- getErrsVar
+       ; (warns, errs) <- readTcRef errs_var
+       ; writeTcRef errs_var (warns `snocBag` warn, errs) }
 
 try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
 -- Does try_m, with a debug-trace on failure
diff --git a/testsuite/tests/typecheck/should_compile/T9939.stderr b/testsuite/tests/typecheck/should_compile/T9939.stderr
index 946fba9..eda780a 100644
--- a/testsuite/tests/typecheck/should_compile/T9939.stderr
+++ b/testsuite/tests/typecheck/should_compile/T9939.stderr
@@ -1,18 +1,18 @@
 
-T9939.hs:5:7:
+T9939.hs:5:7: Warning:
     Redundant constraint: Eq a
     In the type signature for: f1 :: (Eq a, Ord a) => a -> a -> Bool
 
-T9939.hs:9:7:
+T9939.hs:9:7: Warning:
     Redundant constraint: Eq a
     In the type signature for: f2 :: (Eq a, Ord a) => a -> a -> Bool
 
-T9939.hs:13:7:
+T9939.hs:13:7: Warning:
     Redundant constraint: Eq b
     In the type signature for:
        f3 :: (Eq a, a ~ b, Eq b) => a -> b -> Bool
 
-T9939.hs:20:7:
+T9939.hs:20:7: Warning:
     Redundant constraint: Eq b
     In the type signature for:
        f4 :: (Eq a, Eq b) => a -> b -> Equal a b -> Bool
diff --git a/testsuite/tests/typecheck/should_compile/tc056.stderr b/testsuite/tests/typecheck/should_compile/tc056.stderr
index 11641ff..a6f7cd4 100644
--- a/testsuite/tests/typecheck/should_compile/tc056.stderr
+++ b/testsuite/tests/typecheck/should_compile/tc056.stderr
@@ -1,4 +1,4 @@
 
-tc056.hs:16:10:
+tc056.hs:16:10: Warning:
     Redundant constraints: (Eq' a, Eq' a)
     In the instance declaration for ‘Eq' [a]’