summaryrefslogtreecommitdiff
path: root/compiler/typecheck
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/typecheck')
-rw-r--r--compiler/typecheck/Inst.hs4
-rw-r--r--compiler/typecheck/TcAnnotations.hs2
-rw-r--r--compiler/typecheck/TcBinds.hs24
-rw-r--r--compiler/typecheck/TcClassDcl.hs10
-rw-r--r--compiler/typecheck/TcDeriv.hs6
-rw-r--r--compiler/typecheck/TcErrors.hs16
-rw-r--r--compiler/typecheck/TcExpr.hs3
-rw-r--r--compiler/typecheck/TcForeign.hs6
-rw-r--r--compiler/typecheck/TcInstDcls.hs4
-rw-r--r--compiler/typecheck/TcMatches.hs3
-rw-r--r--compiler/typecheck/TcPat.hs2
-rw-r--r--compiler/typecheck/TcRnDriver.hs7
-rw-r--r--compiler/typecheck/TcRnMonad.hs92
-rw-r--r--compiler/typecheck/TcSMonad.hs5
-rw-r--r--compiler/typecheck/TcSimplify.hs2
-rw-r--r--compiler/typecheck/TcSplice.hs4
-rw-r--r--compiler/typecheck/TcTyClsDecls.hs4
-rw-r--r--compiler/typecheck/TcValidity.hs5
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
View Lorry Controller Status