summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/deSugar/Check.hs40
-rw-r--r--compiler/deSugar/Desugar.hs8
-rw-r--r--compiler/deSugar/DsBinds.hs12
-rw-r--r--compiler/deSugar/DsExpr.hs14
-rw-r--r--compiler/deSugar/DsMonad.hs15
-rw-r--r--compiler/deSugar/Match.hs2
-rw-r--r--compiler/deSugar/MatchLit.hs9
7 files changed, 58 insertions, 42 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index 8fa5414b72..fe1b4bc9a3 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -1242,15 +1242,19 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result
exists_i = flag_i && notNull inaccessible
exists_u = flag_u && notNull uncovered
when exists_r $ forM_ redundant $ \(L l q) -> do
- putSrcSpanDs l (warnDs (pprEqn q "is redundant"))
+ putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)
+ (pprEqn q "is redundant"))
when exists_i $ forM_ inaccessible $ \(L l q) -> do
- putSrcSpanDs l (warnDs (pprEqn q "has inaccessible right hand side"))
- when exists_u $ putSrcSpanDs loc (warnDs (pprEqns uncovered))
+ putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)
+ (pprEqn q "has inaccessible right hand side"))
+ when exists_u $
+ putSrcSpanDs loc (warnDs flag_u_reason (pprEqns uncovered))
where
(redundant, uncovered, inaccessible) = pm_result
flag_i = wopt Opt_WarnOverlappingPatterns dflags
flag_u = exhaustive dflags kind
+ flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind)
-- Print a single clause (for redundant/with-inaccessible-rhs)
pprEqn q txt = pp_context True ctx (text txt) $ \f -> ppr_eqn f kind q
@@ -1270,7 +1274,7 @@ warnPmIters :: DynFlags -> DsMatchContext -> PmM ()
warnPmIters dflags (DsMatchContext kind loc)
= when (flag_i || flag_u) $ do
iters <- maxPmCheckIterations <$> getDynFlags
- putSrcSpanDs loc (warnDs (msg iters))
+ putSrcSpanDs loc (warnDs NoReason (msg iters))
where
ctxt = pprMatchContext kind
msg is = fsep [ text "Pattern match checker exceeded"
@@ -1287,17 +1291,23 @@ dots qs | qs `lengthExceeds` maximum_output = text "..."
-- | Check whether the exhaustiveness checker should run (exhaustiveness only)
exhaustive :: DynFlags -> HsMatchContext id -> Bool
-exhaustive dflags (FunRhs {}) = wopt Opt_WarnIncompletePatterns dflags
-exhaustive dflags CaseAlt = wopt Opt_WarnIncompletePatterns dflags
-exhaustive _dflags IfAlt = False
-exhaustive dflags LambdaExpr = wopt Opt_WarnIncompleteUniPatterns dflags
-exhaustive dflags PatBindRhs = wopt Opt_WarnIncompleteUniPatterns dflags
-exhaustive dflags ProcExpr = wopt Opt_WarnIncompleteUniPatterns dflags
-exhaustive dflags RecUpd = wopt Opt_WarnIncompletePatternsRecUpd dflags
-exhaustive _dflags ThPatSplice = False
-exhaustive _dflags PatSyn = False
-exhaustive _dflags ThPatQuote = False
-exhaustive _dflags (StmtCtxt {}) = False -- Don't warn about incomplete patterns
+exhaustive dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag
+
+-- | Denotes whether an exhaustiveness check is supported, and if so,
+-- via which 'WarningFlag' it's controlled.
+-- Returns 'Nothing' if check is not supported.
+exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag
+exhaustiveWarningFlag (FunRhs {}) = Just Opt_WarnIncompletePatterns
+exhaustiveWarningFlag CaseAlt = Just Opt_WarnIncompletePatterns
+exhaustiveWarningFlag IfAlt = Nothing
+exhaustiveWarningFlag LambdaExpr = Just Opt_WarnIncompleteUniPatterns
+exhaustiveWarningFlag PatBindRhs = Just Opt_WarnIncompleteUniPatterns
+exhaustiveWarningFlag ProcExpr = Just Opt_WarnIncompleteUniPatterns
+exhaustiveWarningFlag RecUpd = Just Opt_WarnIncompletePatternsRecUpd
+exhaustiveWarningFlag ThPatSplice = Nothing
+exhaustiveWarningFlag PatSyn = Nothing
+exhaustiveWarningFlag ThPatQuote = Nothing
+exhaustiveWarningFlag (StmtCtxt {}) = Nothing -- Don't warn about incomplete patterns
-- in list comprehensions, pattern guards
-- etc. They are often *supposed* to be
-- incomplete
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs
index 1c175f2cbd..6f14b63b93 100644
--- a/compiler/deSugar/Desugar.hs
+++ b/compiler/deSugar/Desugar.hs
@@ -563,7 +563,7 @@ dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs))
-- Substitute the dict bindings eagerly,
-- and take the body apart into a (f args) form
; case decomposeRuleLhs bndrs'' lhs'' of {
- Left msg -> do { warnDs msg; return Nothing } ;
+ Left msg -> do { warnDs NoReason msg; return Nothing } ;
Right (final_bndrs, fn_id, args) -> do
{ let is_local = isLocalId fn_id
@@ -598,7 +598,8 @@ warnRuleShadowing rule_name rule_act fn_id arg_ids
| isLocalId lhs_id || canUnfold (idUnfolding lhs_id)
-- If imported with no unfolding, no worries
, idInlineActivation lhs_id `competesWith` rule_act
- = warnDs (vcat [ hang (text "Rule" <+> pprRuleName rule_name
+ = warnDs (Reason Opt_WarnInlineRuleShadowing)
+ (vcat [ hang (text "Rule" <+> pprRuleName rule_name
<+> text "may never fire")
2 (text "because" <+> quotes (ppr lhs_id)
<+> text "might inline first")
@@ -608,7 +609,8 @@ warnRuleShadowing rule_name rule_act fn_id arg_ids
| check_rules_too
, bad_rule : _ <- get_bad_rules lhs_id
- = warnDs (vcat [ hang (text "Rule" <+> pprRuleName rule_name
+ = warnDs (Reason Opt_WarnInlineRuleShadowing)
+ (vcat [ hang (text "Rule" <+> pprRuleName rule_name
<+> text "may never fire")
2 (text "because rule" <+> pprRuleName (ruleName bad_rule)
<+> text "for"<+> quotes (ppr lhs_id)
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index da206867d4..5bd31a7900 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -620,16 +620,16 @@ dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding
dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
| isJust (isClassOpId_maybe poly_id)
= putSrcSpanDs loc $
- do { warnDs (text "Ignoring useless SPECIALISE pragma for class method selector"
- <+> quotes (ppr poly_id))
+ do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for class method selector"
+ <+> quotes (ppr poly_id))
; return Nothing } -- There is no point in trying to specialise a class op
-- Moreover, classops don't (currently) have an inl_sat arity set
-- (it would be Just 0) and that in turn makes makeCorePair bleat
| no_act_spec && isNeverActive rule_act
= putSrcSpanDs loc $
- do { warnDs (text "Ignoring useless SPECIALISE pragma for NOINLINE function:"
- <+> quotes (ppr poly_id))
+ do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for NOINLINE function:"
+ <+> quotes (ppr poly_id))
; return Nothing } -- Function is NOINLINE, and the specialiation inherits that
-- See Note [Activation pragmas for SPECIALISE]
@@ -646,7 +646,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
-- , text "spec_co:" <+> ppr spec_co
-- , text "ds_rhs:" <+> ppr ds_lhs ]) $
case decomposeRuleLhs bndrs ds_lhs of {
- Left msg -> do { warnDs msg; return Nothing } ;
+ Left msg -> do { warnDs NoReason msg; return Nothing } ;
Right (rule_bndrs, _fn, args) -> do
{ dflags <- getDynFlags
@@ -717,7 +717,7 @@ dsMkUserRule this_mod is_local name act fn bndrs args rhs = do
let rule = mkRule this_mod False is_local name act fn bndrs args rhs
dflags <- getDynFlags
when (isOrphan (ru_orphan rule) && wopt Opt_WarnOrphans dflags) $
- warnDs (ruleOrphWarn rule)
+ warnDs (Reason Opt_WarnOrphans) (ruleOrphWarn rule)
return rule
ruleOrphWarn :: CoreRule -> SDoc
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 9219d7e9de..2320ab498a 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -1005,8 +1005,8 @@ warnDiscardedDoBindings rhs rhs_ty
-- Warn about discarding non-() things in 'monadic' binding
; if warn_unused && not (isUnitTy norm_elt_ty)
- then warnDs (badMonadBind rhs elt_ty
- (text "-fno-warn-unused-do-bind"))
+ then warnDs (Reason Opt_WarnUnusedDoBind)
+ (badMonadBind rhs elt_ty)
else
-- Warn about discarding m a things in 'monadic' binding of the same type,
@@ -1015,20 +1015,20 @@ warnDiscardedDoBindings rhs rhs_ty
do { case tcSplitAppTy_maybe norm_elt_ty of
Just (elt_m_ty, _)
| m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty
- -> warnDs (badMonadBind rhs elt_ty
- (text "-fno-warn-wrong-do-bind"))
+ -> warnDs (Reason Opt_WarnWrongDoBind)
+ (badMonadBind rhs elt_ty)
_ -> return () } } }
| otherwise -- RHS does have type of form (m ty), which is weird
= return () -- but at lesat this warning is irrelevant
-badMonadBind :: LHsExpr Id -> Type -> SDoc -> SDoc
-badMonadBind rhs elt_ty flag_doc
+badMonadBind :: LHsExpr Id -> Type -> SDoc
+badMonadBind rhs elt_ty
= vcat [ hang (text "A do-notation statement discarded a result of type")
2 (quotes (ppr elt_ty))
, hang (text "Suppress this warning by saying")
2 (quotes $ text "_ <-" <+> ppr rhs)
- , text "or by using the flag" <+> flag_doc ]
+ ]
{-
************************************************************************
diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs
index 0d19ff9d2c..79ca265e4e 100644
--- a/compiler/deSugar/DsMonad.hs
+++ b/compiler/deSugar/DsMonad.hs
@@ -387,12 +387,15 @@ putSrcSpanDs (UnhelpfulSpan {}) thing_inside
putSrcSpanDs (RealSrcSpan real_span) thing_inside
= updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside
-warnDs :: SDoc -> DsM ()
-warnDs warn = do { env <- getGblEnv
- ; loc <- getSrcSpanDs
- ; dflags <- getDynFlags
- ; let msg = mkWarnMsg dflags loc (ds_unqual env) warn
- ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
+-- | Emit a warning for the current source location
+warnDs :: WarnReason -> SDoc -> DsM ()
+warnDs reason warn
+ = do { env <- getGblEnv
+ ; loc <- getSrcSpanDs
+ ; dflags <- getDynFlags
+ ; let msg = makeIntoWarning reason $
+ mkWarnMsg dflags loc (ds_unqual env) warn
+ ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
failWithDs :: SDoc -> DsM a
failWithDs err
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index 763b04f519..fc70cc643d 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -217,7 +217,7 @@ match vars@(v:_) ty eqns -- Eqns *can* be empty
case p of PgView e _ -> e:acc
_ -> acc) [] group) eqns
maybeWarn [] = return ()
- maybeWarn l = warnDs (vcat l)
+ maybeWarn l = warnDs NoReason (vcat l)
in
maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))
(filter (not . null) gs))
diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs
index b1c82ccb90..c66021f6b5 100644
--- a/compiler/deSugar/MatchLit.hs
+++ b/compiler/deSugar/MatchLit.hs
@@ -139,9 +139,9 @@ warnAboutIdentities dflags (Var conv_fn) type_of_conv
, idName conv_fn `elem` conversionNames
, Just (arg_ty, res_ty) <- splitFunTy_maybe type_of_conv
, arg_ty `eqType` res_ty -- So we are converting ty -> ty
- = warnDs (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv
+ = warnDs (Reason Opt_WarnIdentities)
+ (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv
, nest 2 $ text "can probably be omitted"
- , parens (text "Use -fno-warn-identities to suppress this message")
])
warnAboutIdentities _ _ _ = return ()
@@ -173,7 +173,8 @@ warnAboutOverflowedLiterals dflags lit
check :: forall a. (Bounded a, Integral a) => Integer -> Name -> a -> DsM ()
check i tc _proxy
= when (i < minB || i > maxB) $ do
- warnDs (vcat [ text "Literal" <+> integer i
+ warnDs (Reason Opt_WarnOverflowedLiterals)
+ (vcat [ text "Literal" <+> integer i
<+> text "is out of the" <+> ppr tc <+> ptext (sLit "range")
<+> integer minB <> text ".." <> integer maxB
, sug ])
@@ -209,7 +210,7 @@ warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr
, let check :: forall a. (Enum a, Num a) => a -> DsM ()
check _proxy
= when (null enumeration) $
- warnDs (text "Enumeration is empty")
+ warnDs (Reason Opt_WarnEmptyEnumerations) (text "Enumeration is empty")
where
enumeration :: [a]
enumeration = case mThn of
View Lorry Controller Status