Commit 67393977 authored by Georgios Karachalias's avatar Georgios Karachalias Committed by Ben Gamari

(Alternative way to) address #8710

Issue a separate warning per redundant (or inaccessible) clause.
This way each warning can have more precice location information
(the location of the clause under consideration and not the whole
match).

I thought that this could be too much but actually the number of
such warnings is bound by the number of cases matched against (in
contrast to the non-exhaustive warnings which may be exponentially
more).

Test Plan: validate

Reviewers: simonpj, austin, bgamari

Reviewed By: bgamari

Subscribers: thomie

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

GHC Trac Issues: #8710
parent 073e20eb
...@@ -130,7 +130,7 @@ type Triple = (Bool, Uncovered, Bool) ...@@ -130,7 +130,7 @@ type Triple = (Bool, Uncovered, Bool)
-- * Redundant clauses -- * Redundant clauses
-- * Not-covered clauses -- * Not-covered clauses
-- * Clauses with inaccessible RHS -- * Clauses with inaccessible RHS
type PmResult = ([[LPat Id]], Uncovered, [[LPat Id]]) type PmResult = ([Located [LPat Id]], Uncovered, [Located [LPat Id]])
{- {-
%************************************************************************ %************************************************************************
...@@ -142,15 +142,15 @@ type PmResult = ([[LPat Id]], Uncovered, [[LPat Id]]) ...@@ -142,15 +142,15 @@ type PmResult = ([[LPat Id]], Uncovered, [[LPat Id]])
-- | Check a single pattern binding (let) -- | Check a single pattern binding (let)
checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat Id -> DsM () checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat Id -> DsM ()
checkSingle dflags ctxt var p = do checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do
mb_pm_res <- tryM (checkSingle' var p) mb_pm_res <- tryM (checkSingle' locn var p)
case mb_pm_res of case mb_pm_res of
Left _ -> warnPmIters dflags ctxt Left _ -> warnPmIters dflags ctxt
Right res -> dsPmWarn dflags ctxt res Right res -> dsPmWarn dflags ctxt res
-- | Check a single pattern binding (let) -- | Check a single pattern binding (let)
checkSingle' :: Id -> Pat Id -> DsM PmResult checkSingle' :: SrcSpan -> Id -> Pat Id -> DsM PmResult
checkSingle' var p = do checkSingle' locn var p = do
resetPmIterDs -- set the iter-no to zero resetPmIterDs -- set the iter-no to zero
fam_insts <- dsGetFamInstEnvs fam_insts <- dsGetFamInstEnvs
clause <- translatePat fam_insts p clause <- translatePat fam_insts p
...@@ -160,7 +160,7 @@ checkSingle' var p = do ...@@ -160,7 +160,7 @@ checkSingle' var p = do
(True, _ ) -> ([], us, []) -- useful (True, _ ) -> ([], us, []) -- useful
(False, False) -> ( m, us, []) -- redundant (False, False) -> ( m, us, []) -- redundant
(False, True ) -> ([], us, m) -- inaccessible rhs (False, True ) -> ([], us, m) -- inaccessible rhs
where m = [[noLoc p]] where m = [L locn [L locn p]]
-- | Check a matchgroup (case, functions, etc.) -- | Check a matchgroup (case, functions, etc.)
checkMatches :: DynFlags -> DsMatchContext checkMatches :: DynFlags -> DsMatchContext
...@@ -179,7 +179,7 @@ checkMatches' vars matches ...@@ -179,7 +179,7 @@ checkMatches' vars matches
resetPmIterDs -- set the iter-no to zero resetPmIterDs -- set the iter-no to zero
missing <- mkInitialUncovered vars missing <- mkInitialUncovered vars
(rs,us,ds) <- go matches missing (rs,us,ds) <- go matches missing
return (map hsLMatchPats rs, us, map hsLMatchPats ds) return (map hsLMatchToLPats rs, us, map hsLMatchToLPats ds)
where where
go [] missing = return ([], missing, []) go [] missing = return ([], missing, [])
go (m:ms) missing = do go (m:ms) missing = do
...@@ -192,6 +192,9 @@ checkMatches' vars matches ...@@ -192,6 +192,9 @@ checkMatches' vars matches
(False, False) -> (m:rs, final_u, is) -- redundant (False, False) -> (m:rs, final_u, is) -- redundant
(False, True ) -> ( rs, final_u, m:is) -- inaccessible (False, True ) -> ( rs, final_u, m:is) -- inaccessible
hsLMatchToLPats :: LMatch id body -> Located [LPat id]
hsLMatchToLPats (L l (Match _ pats _ _)) = L l pats
{- {-
%************************************************************************ %************************************************************************
%* * %* *
...@@ -1238,22 +1241,22 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result ...@@ -1238,22 +1241,22 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result
let exists_r = flag_i && notNull redundant let exists_r = flag_i && notNull redundant
exists_i = flag_i && notNull inaccessible exists_i = flag_i && notNull inaccessible
exists_u = flag_u && notNull uncovered exists_u = flag_u && notNull uncovered
when exists_r $ putSrcSpanDs loc (warnDs (pprEqns redundant rmsg)) when exists_r $ forM_ redundant $ \(L l q) -> do
when exists_i $ putSrcSpanDs loc (warnDs (pprEqns inaccessible imsg)) putSrcSpanDs l (warnDs (pprEqn q "is redundant"))
when exists_u $ putSrcSpanDs loc (warnDs (pprEqnsU uncovered)) 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))
where where
(redundant, uncovered, inaccessible) = pm_result (redundant, uncovered, inaccessible) = pm_result
flag_i = wopt Opt_WarnOverlappingPatterns dflags flag_i = wopt Opt_WarnOverlappingPatterns dflags
flag_u = exhaustive dflags kind flag_u = exhaustive dflags kind
rmsg = "are redundant" -- Print a single clause (for redundant/with-inaccessible-rhs)
imsg = "have inaccessible right hand side" pprEqn q txt = pp_context True ctx (text txt) $ \f -> ppr_eqn f kind q
pprEqns qs txt = pp_context ctx (text txt) $ \f ->
vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$ dots qs
pprEqnsU qs = pp_context ctx (text "are non-exhaustive") $ \_ -> -- Print several clauses (for uncovered clauses)
pprEqns qs = pp_context False ctx (text "are non-exhaustive") $ \_ ->
case qs of -- See #11245 case qs of -- See #11245
[ValVec [] _] [ValVec [] _]
-> text "Guards do not cover entire pattern space" -> text "Guards do not cover entire pattern space"
...@@ -1299,12 +1302,16 @@ exhaustive _dflags (StmtCtxt {}) = False -- Don't warn about incomplete patterns ...@@ -1299,12 +1302,16 @@ exhaustive _dflags (StmtCtxt {}) = False -- Don't warn about incomplete patterns
-- etc. They are often *supposed* to be -- etc. They are often *supposed* to be
-- incomplete -- incomplete
pp_context :: DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc -- True <==> singular
pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun pp_context :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
= vcat [text "Pattern match(es)" <+> msg, pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun
= vcat [text txt <+> msg,
sep [ text "In" <+> ppr_match <> char ':' sep [ text "In" <+> ppr_match <> char ':'
, nest 4 (rest_of_msg_fun pref)]] , nest 4 (rest_of_msg_fun pref)]]
where where
txt | singular = "Pattern match"
| otherwise = "Pattern match(es)"
(ppr_match, pref) (ppr_match, pref)
= case kind of = case kind of
FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
......
T2395.hs:12:1: warning: T2395.hs:13:1: warning:
Pattern match(es) are redundant Pattern match is redundant
In an equation for ‘bar’: bar _ = ... In an equation for ‘bar’: bar _ = ...
T5117.hs:15:1: Warning: T5117.hs:16:1: warning:
Pattern match(es) are redundant Pattern match is redundant
In an equation for ‘f3’: f3 (MyString "a") = ... In an equation for ‘f3’: f3 (MyString "a") = ...
ds002.hs:7:1: Warning: ds002.hs:8:1: warning:
Pattern match(es) are redundant Pattern match is redundant
In an equation for ‘f’: In an equation for ‘f’: f y = ...
f y = ...
f z = ...
ds002.hs:11:1: Warning: ds002.hs:9:1: warning:
Pattern match(es) are redundant Pattern match is redundant
In an equation for ‘f’: f z = ...
ds002.hs:14:1: warning:
Pattern match is redundant
In an equation for ‘g’: g x y z = ... In an equation for ‘g’: g x y z = ...
ds003.hs:5:1: Warning: ds003.hs:7:1: warning:
Pattern match(es) are redundant Pattern match is redundant
In an equation for ‘f’: In an equation for ‘f’: f (x : x1 : x2 : x3) ~(y, ys) z = ...
f (x : x1 : x2 : x3) ~(y, ys) z = ...
f x y True = ... ds003.hs:8:1: warning:
Pattern match is redundant
In an equation for ‘f’: f x y True = ...
ds019.hs:5:1: Warning: ds019.hs:6:1: warning:
Pattern match(es) are redundant Pattern match is redundant
In an equation for ‘f’: In an equation for ‘f’: f d (j, k) p = ...
f d (j, k) p = ...
f (e, f, g) l q = ... ds019.hs:7:1: warning:
f h (m, n) r = ... Pattern match is redundant
In an equation for ‘f’: f (e, f, g) l q = ...
ds019.hs:8:1: warning:
Pattern match is redundant
In an equation for ‘f’: f h (m, n) r = ...
ds020.hs:8:1: Warning: ds020.hs:9:1: warning:
Pattern match(es) are redundant Pattern match is redundant
In an equation for ‘a’: a ~(~[], ~[], ~[]) = ... In an equation for ‘a’: a ~(~[], ~[], ~[]) = ...
ds020.hs:11:1: Warning: ds020.hs:12:1: warning:
Pattern match(es) are redundant Pattern match is redundant
In an equation for ‘b’: b ~(~x : ~xs : ~ys) = ... In an equation for ‘b’: b ~(~x : ~xs : ~ys) = ...
ds020.hs:16:1: Warning: ds020.hs:19:1: warning:
Pattern match(es) are redundant Pattern match is redundant
In an equation for ‘d’: In an equation for ‘d’: d ~(n+43) = ...
d ~(n+43) = ...
d ~(n+999) = ...
ds020.hs:22:1: Warning: ds020.hs:20:1: warning:
Pattern match(es) are redundant Pattern match is redundant
In an equation for ‘d’: d ~(n+999) = ...
ds020.hs:23:1: warning:
Pattern match is redundant
In an equation for ‘f’: f x@(~[]) = ... In an equation for ‘f’: f x@(~[]) = ...
ds022.hs:22:1: Warning: ds022.hs:24:1: warning:
Pattern match(es) are redundant Pattern match is redundant
In an equation for ‘i’: In an equation for ‘i’: i 1 0.011e2 = ...
i 1 0.011e2 = ...
i 2 2.20000 = ... ds022.hs:25:1: warning:
Pattern match is redundant
In an equation for ‘i’: i 2 2.20000 = ...
ds043.hs:8:2: warning: ds043.hs:10:3: warning:
Pattern match(es) are redundant Pattern match is redundant
In a case alternative: B {e = True, f = False} -> ... In a case alternative: B {e = True, f = False} -> ...
ds051.hs:6:1: Warning: ds051.hs:7:1: warning:
Pattern match(es) are redundant Pattern match is redundant
In an equation for ‘f1’: f1 "ab" = ... In an equation for ‘f1’: f1 "ab" = ...
ds051.hs:11:1: Warning: ds051.hs:12:1: warning:
Pattern match(es) are redundant Pattern match is redundant
In an equation for ‘f2’: f2 ('a' : 'b' : []) = ... In an equation for ‘f2’: f2 ('a' : 'b' : []) = ...
ds051.hs:16:1: Warning: ds051.hs:17:1: warning:
Pattern match(es) are redundant Pattern match is redundant
In an equation for ‘f3’: f3 "ab" = ... In an equation for ‘f3’: f3 "ab" = ...
ds056.hs:8:1: warning: ds056.hs:10:1: warning:
Pattern match(es) are redundant Pattern match is redundant
In an equation for ‘g’: g _ = ... In an equation for ‘g’: g _ = ...
ds058.hs:5:7: warning: ds058.hs:7:9: warning:
Pattern match(es) are redundant Pattern match is redundant
In a case alternative: Just _ -> ... In a case alternative: Just _ -> ...
...@@ -18,13 +18,13 @@ werror.hs:10:1: warning: ...@@ -18,13 +18,13 @@ werror.hs:10:1: warning:
Top-level binding with no type signature: Top-level binding with no type signature:
f :: forall t t1. [t] -> [t1] f :: forall t t1. [t] -> [t1]
werror.hs:10:1: warning:
Pattern match(es) are redundant
In an equation for ‘f’: f [] = ...
werror.hs:10:1: warning: werror.hs:10:1: warning:
Pattern match(es) are non-exhaustive Pattern match(es) are non-exhaustive
In an equation for ‘f’: Patterns not matched: (_:_) In an equation for ‘f’: Patterns not matched: (_:_)
werror.hs:11:1: warning:
Pattern match is redundant
In an equation for ‘f’: f [] = ...
<no location info>: error: <no location info>: error:
Failing due to -Werror. Failing due to -Werror.
T7294.hs:23:1: warning: T7294.hs:25:1: warning:
Pattern match(es) are redundant Pattern match is redundant
In an equation for ‘nth’: nth Nil _ = ... In an equation for ‘nth’: nth Nil _ = ...
T7294.hs:25:5: warning: T7294.hs:25:5: warning:
• Couldn't match type ‘'True’ with ‘'False’ • Couldn't match type ‘'True’ with ‘'False’
Inaccessible code in Inaccessible code in
a pattern with constructor: Nil :: forall a. Vec a 'Zero, a pattern with constructor: Nil :: forall a. Vec a 'Zero,
in an equation for ‘nth’ in an equation for ‘nth’
• In the pattern: Nil • In the pattern: Nil
In an equation for ‘nth’: nth Nil _ = undefined In an equation for ‘nth’: nth Nil _ = undefined
...@@ -18,7 +18,7 @@ ...@@ -18,7 +18,7 @@
In an equation for ‘b’: b x = x == x In an equation for ‘b’: b x = x == x
../../typecheck/should_run/Defer01.hs:25:1: warning: ../../typecheck/should_run/Defer01.hs:25:1: warning:
Pattern match(es) have inaccessible right hand side Pattern match has inaccessible right hand side
In an equation for ‘c’: c (C2 x) = ... In an equation for ‘c’: c (C2 x) = ...
../../typecheck/should_run/Defer01.hs:25:4: warning: ../../typecheck/should_run/Defer01.hs:25:4: warning:
...@@ -103,7 +103,7 @@ ...@@ -103,7 +103,7 @@
k :: (Int ~ Bool) => Int -> Bool k :: (Int ~ Bool) => Int -> Bool
../../typecheck/should_run/Defer01.hs:46:1: warning: ../../typecheck/should_run/Defer01.hs:46:1: warning:
Pattern match(es) are redundant Pattern match is redundant
In an equation for ‘k’: k x = ... In an equation for ‘k’: k x = ...
../../typecheck/should_run/Defer01.hs:49:5: warning: ../../typecheck/should_run/Defer01.hs:49:5: warning:
......
pmc003.hs:6:1: warning:
Pattern match(es) have inaccessible right hand side pmc003.hs:7:1: warning:
Pattern match has inaccessible right hand side
In an equation for ‘f’: f True False = ... In an equation for ‘f’: f True False = ...
pmc004.hs:15:1: warning:
Pattern match(es) have inaccessible right hand side pmc004.hs:16:1: warning:
Pattern match has inaccessible right hand side
In an equation for ‘h’: h _ G1 = ... In an equation for ‘h’: h _ G1 = ...
pmc005.hs:11:1: warning:
Pattern match(es) have inaccessible right hand side
In an equation for ‘foo’: foo _ TList = ...
pmc005.hs:11:1: warning: pmc005.hs:11:1: warning:
Pattern match(es) are non-exhaustive Pattern match(es) are non-exhaustive
In an equation for ‘foo’: Patterns not matched: TBool TBool In an equation for ‘foo’: Patterns not matched: TBool TBool
pmc005.hs:12:1: warning:
Pattern match has inaccessible right hand side
In an equation for ‘foo’: foo _ TList = ...
...@@ -5,5 +5,5 @@ case (# 'b', GHC.Types.False #) of ...@@ -5,5 +5,5 @@ case (# 'b', GHC.Types.False #) of
(# _, _ #) -> (# "Three", 3 #) (# _, _ #) -> (# "Three", 3 #)
TH_repUnboxedTuples.hs:18:13: warning: TH_repUnboxedTuples.hs:18:13: warning:
Pattern match(es) are redundant Pattern match is redundant
In a case alternative: (# 'a', True #) -> ... In a case alternative: (# 'a', True #) -> ...
T5490.hs:245:15: warning: T5490.hs:246:5: warning:
Pattern match(es) are redundant Pattern match is redundant
In a case alternative: HDropZero -> ... In a case alternative: HDropZero -> ...
T5490.hs:288:3: warning: T5490.hs:295:5: warning:
Pattern match(es) are redundant Pattern match is redundant
In a case alternative: _ -> ... In a case alternative: _ -> ...
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment