Print which warning-flag controls an emitted warning.wip/D1934

Summary:
Both gcc and clang tell which warning flag a reported warning can be
controlled with, this patch makes ghc do the same. More generally, this
allows for annotated compiler output, where an optional annotation is
displayed in brackets after the severity.

Fixes T10752.

Reviewers: austin, hvr, goldfire, bgamari

Subscribers: goldfire, thomie

Differential Revision: https://phabricator.haskell.org/D1934

18 files changed, 121 insertions, 78 deletions

diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs
index b3da5ef5ea..03dad405a0 100644
--- a/compiler/typecheck/Inst.hs
+++ b/compiler/typecheck/Inst.hs
@@ -520,7 +520,9 @@ newClsInst overlap_mode dfun_name tvs theta clas tys
        ; oflag <- getOverlapFlag overlap_mode
        ; let inst = mkLocalInstance dfun oflag tvs' clas tys'
        ; dflags <- getDynFlags
-       ; warnIf (isOrphan (is_orphan inst) && wopt Opt_WarnOrphans dflags) (instOrphWarn inst)
+       ; warnIf Opt_WarnOrphans
+             (isOrphan (is_orphan inst) && wopt Opt_WarnOrphans dflags)
+             (instOrphWarn inst)
        ; return inst }
 
 instOrphWarn :: ClsInst -> SDoc
diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs
index b80d5bd236..e1bb975abf 100644
--- a/compiler/typecheck/TcAnnotations.hs
+++ b/compiler/typecheck/TcAnnotations.hs
@@ -29,7 +29,7 @@ tcAnnotations :: [LAnnDecl Name] -> TcM [Annotation]
 -- No GHCI; emit a warning (not an error) and ignore. cf Trac #4268
 tcAnnotations [] = return []
 tcAnnotations anns@(L loc _ : _)
-  = do { setSrcSpan loc $ addWarnTc $
+  = do { setSrcSpan loc $ addWarnTc' $
              (text "Ignoring ANN annotation" <> plural anns <> comma
              <+> text "because this is a stage-1 compiler or doesn't support GHCi")
        ; return [] }
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 43f933b70d..3835bf185c 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -707,7 +707,8 @@ mkExport prag_fn qtvs theta
                        tcSubType_NC sig_ctxt sel_poly_ty (mkCheckExpType poly_ty)
 
         ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSigs
-        ; when warn_missing_sigs $ localSigWarn poly_id mb_sig
+        ; when warn_missing_sigs $
+              localSigWarn Opt_WarnMissingLocalSigs poly_id mb_sig
 
         ; return (ABE { abe_wrap = wrap
                         -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty)
@@ -797,7 +798,8 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs
                  , ppr annotated_theta, ppr inferred_theta
                  , ppr inferred_diff ]
        ; case partial_sigs of
-           True | warn_partial_sigs -> reportWarning msg
+           True | warn_partial_sigs ->
+                      reportWarning (Just Opt_WarnPartialTypeSignatures) msg
                 | otherwise         -> return ()
            False                    -> reportError msg
 
@@ -851,19 +853,19 @@ mk_inf_msg poly_name poly_ty tidy_env
 
 
 -- | Warn the user about polymorphic local binders that lack type signatures.
-localSigWarn :: Id -> Maybe TcIdSigInfo -> TcM ()
-localSigWarn id mb_sig
+localSigWarn :: WarningFlag -> Id -> Maybe TcIdSigInfo -> TcM ()
+localSigWarn flag id mb_sig
   | Just _ <- mb_sig               = return ()
   | not (isSigmaTy (idType id))    = return ()
-  | otherwise                      = warnMissingSig msg id
+  | otherwise                      = warnMissingSig flag msg id
   where
     msg = text "Polymorphic local binding with no type signature:"
 
-warnMissingSig :: SDoc -> Id -> TcM ()
-warnMissingSig msg id
+warnMissingSig :: WarningFlag -> SDoc -> Id -> TcM ()
+warnMissingSig flag msg id
   = do  { env0 <- tcInitTidyEnv
         ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
-        ; addWarnTcM (env1, mk_msg tidy_ty) }
+        ; addWarnTcM flag (env1, mk_msg tidy_ty) }
   where
     mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]
 
@@ -1126,7 +1128,7 @@ tcSpecPrags poly_id prag_sigs
     is_bad_sig s = not (isSpecLSig s || isInlineLSig s)
 
     warn_discarded_sigs
-      = addWarnTc (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id)
+      = addWarnTc' (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id)
                       2 (vcat (map (ppr . getLoc) bad_sigs)))
 
 --------------
@@ -1140,7 +1142,7 @@ tcSpecPrag poly_id prag@(SpecSig fun_name hs_tys inl)
 -- However we want to use fun_name in the error message, since that is
 -- what the user wrote (Trac #8537)
   = addErrCtxt (spec_ctxt prag) $
-    do  { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))
+    do  { warnIf' (not (isOverloadedTy poly_ty || isInlinePragma inl))
                  (text "SPECIALISE pragma for non-overloaded function"
                   <+> quotes (ppr fun_name))
                   -- Note [SPECIALISE pragmas]
@@ -1206,7 +1208,7 @@ tcImpSpec :: (Name, Sig Name) -> TcM [TcSpecPrag]
 tcImpSpec (name, prag)
  = do { id <- tcLookupId name
       ; unless (isAnyInlinePragma (idInlinePragma id))
-               (addWarnTc (impSpecErr name))
+               (addWarnTc' (impSpecErr name))
       ; tcSpecPrag id prag }
 
 impSpecErr :: Name -> SDoc
diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs
index b1baabb963..3ccebeff0c 100644
--- a/compiler/typecheck/TcClassDcl.hs
+++ b/compiler/typecheck/TcClassDcl.hs
@@ -210,9 +210,9 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
 
        ; spec_prags <- discardConstraints $
                        tcSpecPrags global_dm_id prags
-       ; warnTc (not (null spec_prags))
-                (text "Ignoring SPECIALISE pragmas on default method"
-                 <+> quotes (ppr sel_name))
+       ; warnTc' (not (null spec_prags))
+                 (text "Ignoring SPECIALISE pragmas on default method"
+                  <+> quotes (ppr sel_name))
 
        ; let hs_ty = lookupHsSig hs_sig_fn sel_name
                      `orElse` pprPanic "tc_dm" (ppr sel_name)
@@ -280,7 +280,7 @@ tcClassMinimalDef _clas sigs op_info
         -- class ops without default methods are required, since we
         -- have no way to fill them in otherwise
         whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $
-                   (\bf -> addWarnTc (warningMinimalDefIncomplete bf))
+                   (\bf -> addWarnTc' (warningMinimalDefIncomplete bf))
         return mindef
   where
     -- By default require all methods without a default
@@ -487,7 +487,7 @@ warnMissingAT :: Name -> TcM ()
 warnMissingAT name
   = do { warn <- woptM Opt_WarnMissingMethods
        ; traceTc "warn" (ppr name <+> ppr warn)
-       ; warnTc warn  -- Warn only if -Wmissing-methods
+       ; warnTc Opt_WarnMissingMethods warn  -- Warn only if -Wmissing-methods
                 (text "No explicit" <+> text "associated type"
                     <+> text "or default declaration for     "
                     <+> quotes (ppr name)) }
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 56772f2b1a..2c205069da 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -559,7 +559,7 @@ deriveStandalone (L loc (DerivDecl deriv_ty overlap_mode))
 warnUselessTypeable :: TcM ()
 warnUselessTypeable
   = do { warn <- woptM Opt_WarnDerivingTypeable
-       ; when warn $ addWarnTc
+       ; when warn $ addWarnTc Opt_WarnDerivingTypeable
                    $ text "Deriving" <+> quotes (ppr typeableClassName) <+>
                      text "has no effect: all types now auto-derive Typeable" }
 
@@ -1499,8 +1499,8 @@ mkNewTypeEqn dflags overlap_mode tvs
 
       -- CanDerive/DerivableViaInstance
       _ -> do when (newtype_deriving && deriveAnyClass) $
-                addWarnTc (sep [ text "Both DeriveAnyClass and GeneralizedNewtypeDeriving are enabled"
-                               , text "Defaulting to the DeriveAnyClass strategy for instantiating" <+> ppr cls ])
+                addWarnTc' (sep [ text "Both DeriveAnyClass and GeneralizedNewtypeDeriving are enabled"
+                                , text "Defaulting to the DeriveAnyClass strategy for instantiating" <+> ppr cls ])
               go_for_it
   where
         newtype_deriving  = xopt LangExt.GeneralizedNewtypeDeriving dflags
diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
index 2140a797ff..75a3b5cbb7 100644
--- a/compiler/typecheck/TcErrors.hs
+++ b/compiler/typecheck/TcErrors.hs
@@ -342,13 +342,13 @@ warnRedundantConstraints ctxt env info ev_vars
    addErrCtxt (text "In" <+> ppr info) $
    do { env <- getLclEnv
       ; msg <- mkErrorReport ctxt env (important doc)
-      ; reportWarning msg }
+      ; reportWarning Nothing msg }
 
  | otherwise  -- But for InstSkol there already *is* a surrounding
               -- "In the instance declaration for Eq [a]" context
               -- and we don't want to say it twice. Seems a bit ad-hoc
  = do { msg <- mkErrorReport ctxt env (important doc)
-      ; reportWarning msg }
+      ; reportWarning Nothing msg }
  where
    doc = text "Redundant constraint" <> plural redundant_evs <> colon
          <+> pprEvVarTheta redundant_evs
@@ -573,7 +573,7 @@ reportGroup mk_err ctxt cts =
         -- Only warn about missing MonadFail constraint when
         -- there are no other missing contstraints!
         (monadFailCts, []) -> do { err <- mk_err ctxt monadFailCts
-                                 ; reportWarning err }
+                                 ; reportWarning Nothing err }
 
         (_, cts') -> do { err <- mk_err ctxt cts'
                         ; maybeReportError ctxt err
@@ -597,7 +597,7 @@ maybeReportHoleError ctxt ct err
     -- only if -fwarn_partial_type_signatures is on
     case cec_type_holes ctxt of
        HoleError -> reportError err
-       HoleWarn  -> reportWarning err
+       HoleWarn  -> reportWarning (Just Opt_WarnPartialTypeSignatures) err
        HoleDefer -> return ()
 
   -- Otherwise this is a typed hole in an expression
@@ -605,7 +605,7 @@ maybeReportHoleError ctxt ct err
   = -- If deferring, report a warning only if -Wtyped-holds is on
     case cec_expr_holes ctxt of
        HoleError -> reportError err
-       HoleWarn  -> reportWarning err
+       HoleWarn  -> reportWarning (Just Opt_WarnTypedHoles) err
        HoleDefer -> return ()
 
 maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM ()
@@ -615,12 +615,12 @@ maybeReportError ctxt err
   = return ()            -- so suppress this error/warning
 
   | cec_errors_as_warns ctxt
-  = reportWarning err
+  = reportWarning Nothing err
 
   | otherwise
   = case cec_defer_type_errors ctxt of
       TypeDefer -> return ()
-      TypeWarn  -> reportWarning err
+      TypeWarn  -> reportWarning Nothing err
       TypeError -> reportError err
 
 addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
@@ -2328,7 +2328,7 @@ warnDefaulting wanteds default_ty
                            , quotes (ppr default_ty) ])
                      2
                      ppr_wanteds
-       ; setCtLocM loc $ warnTc warn_default warn_msg }
+       ; setCtLocM loc $ warnTc Opt_WarnTypeDefaults warn_default warn_msg }
 
 {-
 Note [Runtime skolems]
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index d54fbc7644..025d376e77 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -2221,7 +2221,8 @@ checkMissingFields con_like rbinds
 
     warn <- woptM Opt_WarnMissingFields
     unless (not (warn && notNull missing_ns_fields))
-           (warnTc True (missingFields con_like missing_ns_fields))
+           (warnTc Opt_WarnMissingFields True
+               (missingFields con_like missing_ns_fields))
 
   where
     missing_s_fields
diff --git a/compiler/typecheck/TcForeign.hs b/compiler/typecheck/TcForeign.hs
index bc3a9283c6..bca9a5603d 100644
--- a/compiler/typecheck/TcForeign.hs
+++ b/compiler/typecheck/TcForeign.hs
@@ -349,7 +349,8 @@ checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()
 checkMissingAmpersand dflags arg_tys res_ty
   | null arg_tys && isFunPtrTy res_ty &&
     wopt Opt_WarnDodgyForeignImports dflags
-  = addWarn (text "possible missing & in foreign import of FunPtr")
+  = addWarn Opt_WarnDodgyForeignImports
+        (text "possible missing & in foreign import of FunPtr")
   | otherwise
   = return ()
 
@@ -522,7 +523,8 @@ checkCConv StdCallConv  = do dflags <- getDynFlags
                                  then return StdCallConv
                                  else do -- This is a warning, not an error. see #3336
                                          when (wopt Opt_WarnUnsupportedCallingConventions dflags) $
-                                             addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")
+                                             addWarnTc Opt_WarnUnsupportedCallingConventions
+                                                 (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")
                                          return CCallConv
 checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'")
                              return PrimCallConv
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index 82c66cc953..5b433860bd 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -447,7 +447,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
            if isHsBootOrSig (tcg_src env)
              then
                do warn <- woptM Opt_WarnDerivingTypeable
-                  when warn $ addWarnTc $ vcat
+                  when warn $ addWarnTc Opt_WarnDerivingTypeable $ vcat
                     [ ppTypeable <+> text "instances in .hs-boot files are ignored"
                     , text "This warning will become an error in future versions of the compiler"
                     ]
@@ -1570,7 +1570,7 @@ derivBindCtxt sel_id clas tys
 warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM ()
 warnUnsatisfiedMinimalDefinition mindef
   = do { warn <- woptM Opt_WarnMissingMethods
-       ; warnTc warn message
+       ; warnTc Opt_WarnMissingMethods warn message
        }
   where
     message = vcat [text "No explicit implementation for"
diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs
index 5f3bc5b73a..0070cb79c6 100644
--- a/compiler/typecheck/TcMatches.hs
+++ b/compiler/typecheck/TcMatches.hs
@@ -975,7 +975,8 @@ emitMonadFailConstraint pat res_ty
        ; return () }
 
 warnRebindableClash :: LPat TcId -> TcRn ()
-warnRebindableClash pattern = addWarnAt (getLoc pattern)
+warnRebindableClash pattern = addWarnAt Opt_WarnMissingMonadFailInstances
+    (getLoc pattern)
     (text "The failable pattern" <+> quotes (ppr pattern)
      $$
      nest 2 (text "is used together with -XRebindableSyntax."
diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs
index 4d1d09a32f..4eaaa58fc9 100644
--- a/compiler/typecheck/TcPat.hs
+++ b/compiler/typecheck/TcPat.hs
@@ -219,7 +219,7 @@ addInlinePrags poly_id prags
          warn_multiple_inlines inl2 inls
        | otherwise
        = setSrcSpan loc $
-         addWarnTc (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id)
+         addWarnTc' (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id)
                        2 (vcat (text "Ignoring all but the first"
                                 : map pp_inl (inl1:inl2:inls))))
 
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index fdc6e5e638..385405f6a7 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -310,7 +310,8 @@ tcRnModuleTcRnM hsc_env hsc_src
                                          implicit_prelude import_decls } ;
 
         whenWOptM Opt_WarnImplicitPrelude $
-             when (notNull prel_imports) $ addWarn (implicitPreludeWarn) ;
+             when (notNull prel_imports) $
+                  addWarn Opt_WarnImplicitPrelude (implicitPreludeWarn) ;
 
         tcg_env <- {-# SCC "tcRnImports" #-}
                    tcRnImports hsc_env (prel_imports ++ import_decls) ;
@@ -1286,7 +1287,7 @@ tcPreludeClashWarn warnFlag name = do
     ; traceTc "tcPreludeClashWarn/prelude_functions"
                 (hang (ppr name) 4 (sep [ppr clashingElts]))
 
-    ; let warn_msg x = addWarnAt (nameSrcSpan (gre_name x)) (hsep
+    ; let warn_msg x = addWarnAt warnFlag (nameSrcSpan (gre_name x)) (hsep
               [ text "Local definition of"
               , (quotes . ppr . nameOccName . gre_name) x
               , text "clashes with a future Prelude name." ]
@@ -1397,7 +1398,7 @@ tcMissingParentClassWarn warnFlag isName shouldName
            -- <should>" e.g. "Foo is an instance of Monad but not Applicative"
            ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst
                  warnMsg (Just name:_) =
-                      addWarnAt instLoc $
+                      addWarnAt warnFlag instLoc $
                            hsep [ (quotes . ppr . nameOccName) name
                                 , text "is an instance of"
                                 , (ppr . nameOccName . className) isClass
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index 8cf0d748e3..1db87e4602 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -719,9 +719,13 @@ checkErr :: Bool -> MsgDoc -> TcRn ()
 -- Add the error if the bool is False
 checkErr ok msg = unless ok (addErr msg)
 
-warnIf :: Bool -> MsgDoc -> TcRn ()
-warnIf True  msg = addWarn msg
-warnIf False _   = return ()
+warnIf :: WarningFlag -> Bool -> MsgDoc -> TcRn ()
+warnIf flag True  msg = addWarn flag msg
+warnIf _    False _   = return ()
+
+warnIf' :: Bool -> MsgDoc -> TcRn ()
+warnIf' True  msg = addWarn' msg
+warnIf' False _   = return ()
 
 addMessages :: Messages -> TcRn ()
 addMessages msgs1
@@ -777,9 +781,9 @@ reportError err
          (warns, errs) <- readTcRef errs_var ;
          writeTcRef errs_var (warns, errs `snocBag` err) }
 
-reportWarning :: ErrMsg -> TcRn ()
-reportWarning err
-  = do { let warn = makeIntoWarning err
+reportWarning :: Maybe WarningFlag -> ErrMsg -> TcRn ()
+reportWarning flag err
+  = do { let warn = makeIntoWarning flag err
                     -- 'err' was built by mkLongErrMsg or something like that,
                     -- so it's of error severity.  For a warning we downgrade
                     -- its severity to SevWarning
@@ -1081,44 +1085,70 @@ failIfTcM True  err = failWithTcM err
 
 --         Warnings have no 'M' variant, nor failure
 
-warnTc :: Bool -> MsgDoc -> TcM ()
-warnTc warn_if_true warn_msg
-  | warn_if_true = addWarnTc warn_msg
+warnTc :: WarningFlag -> Bool -> MsgDoc -> TcM ()
+warnTc flag warn_if_true warn_msg
+  | warn_if_true = addWarnTc flag warn_msg
+  | otherwise    = return ()
+
+warnTc' :: Bool -> MsgDoc -> TcM ()
+warnTc' warn_if_true warn_msg
+  | warn_if_true = addWarnTc' warn_msg
   | otherwise    = return ()
 
-warnTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()
-warnTcM warn_if_true warn_msg
-  | warn_if_true = addWarnTcM warn_msg
+warnTcM :: WarningFlag -> Bool -> (TidyEnv, MsgDoc) -> TcM ()
+warnTcM flag warn_if_true warn_msg
+  | warn_if_true = addWarnTcM flag warn_msg
   | otherwise    = return ()
 
-addWarnTc :: MsgDoc -> TcM ()
-addWarnTc msg = do { env0 <- tcInitTidyEnv
-                   ; addWarnTcM (env0, msg) }
+warnTcM' :: Bool -> (TidyEnv, MsgDoc) -> TcM ()
+warnTcM' warn_if_true warn_msg
+  | warn_if_true = addWarnTcM' warn_msg
+  | otherwise    = return ()
+
+addWarnTc :: WarningFlag -> MsgDoc -> TcM ()
+addWarnTc flag msg = do { env0 <- tcInitTidyEnv
+                   ; addWarnTcM flag (env0, msg) }
+
+addWarnTc' :: MsgDoc -> TcM ()
+addWarnTc' msg = do { env0 <- tcInitTidyEnv
+                   ; addWarnTcM' (env0, msg) }
 
-addWarnTcM :: (TidyEnv, MsgDoc) -> TcM ()
-addWarnTcM (env0, msg)
+addWarnTcM :: WarningFlag -> (TidyEnv, MsgDoc) -> TcM ()
+addWarnTcM flag (env0, msg)
  = do { ctxt <- getErrCtxt ;
         err_info <- mkErrInfo env0 ctxt ;
-        add_warn msg err_info }
+        add_warn (Just flag) msg err_info }
+
+addWarnTcM' :: (TidyEnv, MsgDoc) -> TcM ()
+addWarnTcM' (env0, msg)
+ = do { ctxt <- getErrCtxt ;
+        err_info <- mkErrInfo env0 ctxt ;
+        add_warn Nothing msg err_info }
+
+addWarn :: WarningFlag -> MsgDoc -> TcRn ()
+addWarn flag msg = add_warn (Just flag) msg Outputable.empty
+
+addWarn' :: MsgDoc -> TcRn ()
+addWarn' msg = add_warn Nothing msg Outputable.empty
 
-addWarn :: MsgDoc -> TcRn ()
-addWarn msg = add_warn msg Outputable.empty
+addWarnAt :: WarningFlag -> SrcSpan -> MsgDoc -> TcRn ()
+addWarnAt flag loc msg = add_warn_at (Just flag) loc msg Outputable.empty
 
-addWarnAt :: SrcSpan -> MsgDoc -> TcRn ()
-addWarnAt loc msg = add_warn_at loc msg Outputable.empty
+addWarnAt' :: SrcSpan -> MsgDoc -> TcRn ()
+addWarnAt' loc msg = add_warn_at Nothing loc msg Outputable.empty
 
-add_warn :: MsgDoc -> MsgDoc -> TcRn ()
-add_warn msg extra_info
+add_warn :: Maybe WarningFlag -> MsgDoc -> MsgDoc -> TcRn ()
+add_warn flag msg extra_info
   = do { loc <- getSrcSpanM
-       ; add_warn_at loc msg extra_info }
+       ; add_warn_at flag loc msg extra_info }
 
-add_warn_at :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
-add_warn_at loc msg extra_info
+add_warn_at :: Maybe WarningFlag -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
+add_warn_at flag loc msg extra_info
   = do { dflags <- getDynFlags ;
          printer <- getPrintUnqualified dflags ;
          let { warn = mkLongWarnMsg dflags loc printer
                                     msg extra_info } ;
-         reportWarning warn }
+         reportWarning flag warn }
 
 tcInitTidyEnv :: TcM TidyEnv
 tcInitTidyEnv
@@ -1486,7 +1516,8 @@ failIfM msg
   = do  { env <- getLclEnv
         ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
         ; dflags <- getDynFlags
-        ; liftIO (log_action dflags dflags SevFatal noSrcSpan (defaultErrStyle dflags) full_msg)
+        ; liftIO (log_action dflags dflags Nothing SevFatal
+                   noSrcSpan (defaultErrStyle dflags) full_msg)
         ; failM }
 
 --------------------
@@ -1522,7 +1553,8 @@ forkM_maybe doc thing_inside
                           dflags <- getDynFlags
                           let msg = hang (text "forkM failed:" <+> doc)
                                        2 (text (show exn))
-                          liftIO $ log_action dflags dflags SevFatal noSrcSpan (defaultErrStyle dflags) msg
+                          liftIO $ log_action dflags dflags Nothing SevFatal
+                                     noSrcSpan (defaultErrStyle dflags) msg
 
                     ; traceIf (text "} ending fork (badly)" <+> doc)
                     ; return Nothing }
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index 053c53b86a..08a0bd87dc 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -2351,9 +2351,10 @@ wrapWarnTcS :: TcM a -> TcS a
 wrapWarnTcS = wrapTcS
 
 failTcS, panicTcS  :: SDoc -> TcS a
-warnTcS, addErrTcS :: SDoc -> TcS ()
+warnTcS   :: WarningFlag -> SDoc -> TcS ()
+addErrTcS :: SDoc -> TcS ()
 failTcS      = wrapTcS . TcM.failWith
-warnTcS      = wrapTcS . TcM.addWarn
+warnTcS flag = wrapTcS . TcM.addWarn flag
 addErrTcS    = wrapTcS . TcM.addErr
 panicTcS doc = pprPanic "TcCanonical" doc
 
diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs
index be0735816b..bb86482590 100644
--- a/compiler/typecheck/TcSimplify.hs
+++ b/compiler/typecheck/TcSimplify.hs
@@ -742,7 +742,7 @@ decideQuantification apply_mr sigs name_taus constraints
            -- Warn about the monomorphism restriction
        ; warn_mono <- woptM Opt_WarnMonomorphism
        ; let mr_bites = constrained_tvs `intersectsVarSet` zonked_tkvs
-       ; warnTc (warn_mono && mr_bites) $
+       ; warnTc Opt_WarnMonomorphism (warn_mono && mr_bites) $
          hang (text "The Monomorphism Restriction applies to the binding"
                <> plural bndrs <+> text "for" <+> pp_bndrs)
              2 (text "Consider giving a type signature for"
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 921da07d2d..6ea4fa3bc5 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -806,8 +806,8 @@ instance TH.Quasi TcM where
 
   -- 'msg' is forced to ensure exceptions don't escape,
   -- see Note [Exceptions in TH]
-  qReport True msg  = seqList msg $ addErr  (text msg)
-  qReport False msg = seqList msg $ addWarn (text msg)
+  qReport True msg  = seqList msg $ addErr   (text msg)
+  qReport False msg = seqList msg $ addWarn' (text msg)
 
   qLocation = do { m <- getModule
                  ; l <- getSrcSpanM
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index e68efd09f9..e550fe0eb4 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -2125,13 +2125,13 @@ checkValidDataCon dflags existential_ok tc con
           (bad_bang n (text "Lazy annotation (~) without StrictData"))
     check_bang (HsSrcBang _ want_unpack strict_mark) rep_bang n
       | isSrcUnpacked want_unpack, not is_strict
-      = addWarnTc (bad_bang n (text "UNPACK pragma lacks '!'"))
+      = addWarnTc' (bad_bang n (text "UNPACK pragma lacks '!'"))
       | isSrcUnpacked want_unpack
       , case rep_bang of { HsUnpack {} -> False; _ -> True }
       , not (gopt Opt_OmitInterfacePragmas dflags)
            -- If not optimising, se don't unpack, so don't complain!
            -- See MkId.dataConArgRep, the (HsBang True) case
-      = addWarnTc (bad_bang n (text "Ignoring unusable UNPACK pragma"))
+      = addWarnTc' (bad_bang n (text "Ignoring unusable UNPACK pragma"))
       where
         is_strict = case strict_mark of
                       NoSrcStrict -> xopt LangExt.StrictData dflags
diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs
index 56cb348669..b018b52994 100644
--- a/compiler/typecheck/TcValidity.hs
+++ b/compiler/typecheck/TcValidity.hs
@@ -684,7 +684,8 @@ check_valid_theta _ _ []
   = return ()
 check_valid_theta env ctxt theta
   = do { dflags <- getDynFlags
-       ; warnTcM (wopt Opt_WarnDuplicateConstraints dflags &&
+       ; warnTcM Opt_WarnDuplicateConstraints
+                 (wopt Opt_WarnDuplicateConstraints dflags &&
                   notNull dups) (dupPredWarn env dups)
        ; traceTc "check_valid_theta" (ppr theta)
        ; mapM_ (check_pred_ty env dflags ctxt) theta }
@@ -1455,7 +1456,7 @@ checkValidCoAxiom ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches })
     --   (b) failure of injectivity
     check_branch_compat prev_branches cur_branch
       | cur_branch `isDominatedBy` prev_branches
-      = do { addWarnAt (coAxBranchSpan cur_branch) $
+      = do { addWarnAt' (coAxBranchSpan cur_branch) $
              inaccessibleCoAxBranch ax cur_branch
            ; return prev_branches }
       | otherwise