(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

20 files changed, 122 insertions, 99 deletions

diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index 5570ce963e..8fa5414b72 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -130,7 +130,7 @@ type Triple = (Bool, Uncovered, Bool)
 -- * Redundant clauses
 -- * Not-covered clauses
 -- * 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]])
 
 -- | Check a single pattern binding (let)
 checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat Id -> DsM ()
-checkSingle dflags ctxt var p = do
-  mb_pm_res <- tryM (checkSingle' var p)
+checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do
+  mb_pm_res <- tryM (checkSingle' locn var p)
   case mb_pm_res of
     Left  _   -> warnPmIters dflags ctxt
     Right res -> dsPmWarn dflags ctxt res
 
 -- | Check a single pattern binding (let)
-checkSingle' :: Id -> Pat Id -> DsM PmResult
-checkSingle' var p = do
+checkSingle' :: SrcSpan -> Id -> Pat Id -> DsM PmResult
+checkSingle' locn var p = do
   resetPmIterDs -- set the iter-no to zero
   fam_insts <- dsGetFamInstEnvs
   clause    <- translatePat fam_insts p
@@ -160,7 +160,7 @@ checkSingle' var p = do
     (True,  _    ) -> ([], us, []) -- useful
     (False, False) -> ( m, us, []) -- redundant
     (False, True ) -> ([], us,  m) -- inaccessible rhs
-  where m = [[noLoc p]]
+  where m = [L locn [L locn p]]
 
 -- | Check a matchgroup (case, functions, etc.)
 checkMatches :: DynFlags -> DsMatchContext
@@ -179,7 +179,7 @@ checkMatches' vars matches
       resetPmIterDs -- set the iter-no to zero
       missing    <- mkInitialUncovered vars
       (rs,us,ds) <- go matches missing
-      return (map hsLMatchPats rs, us, map hsLMatchPats ds)
+      return (map hsLMatchToLPats rs, us, map hsLMatchToLPats ds)
   where
     go []     missing = return ([], missing, [])
     go (m:ms) missing = do
@@ -192,6 +192,9 @@ checkMatches' vars matches
         (False, False) -> (m:rs, final_u,   is) -- redundant
         (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
       let exists_r = flag_i && notNull redundant
           exists_i = flag_i && notNull inaccessible
           exists_u = flag_u && notNull uncovered
-      when exists_r $ putSrcSpanDs loc (warnDs (pprEqns  redundant    rmsg))
-      when exists_i $ putSrcSpanDs loc (warnDs (pprEqns  inaccessible imsg))
-      when exists_u $ putSrcSpanDs loc (warnDs (pprEqnsU uncovered))
+      when exists_r $ forM_ redundant $ \(L l q) -> do
+        putSrcSpanDs l (warnDs (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))
   where
     (redundant, uncovered, inaccessible) = pm_result
 
     flag_i = wopt Opt_WarnOverlappingPatterns dflags
     flag_u = exhaustive dflags kind
 
-    rmsg = "are redundant"
-    imsg = "have inaccessible right hand side"
-
-    pprEqns qs txt = pp_context ctx (text txt) $ \f ->
-      vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$ dots qs
+    -- Print a single clause (for redundant/with-inaccessible-rhs)
+    pprEqn q txt = pp_context True ctx (text txt) $ \f -> ppr_eqn f kind q
 
-    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
            [ValVec [] _]
                     -> text "Guards do not cover entire pattern space"
@@ -1299,12 +1302,16 @@ exhaustive _dflags (StmtCtxt {}) = False -- Don't warn about incomplete patterns
                                        -- etc. They are often *supposed* to be
                                        -- incomplete
 
-pp_context :: DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
-pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun
-  = vcat [text "Pattern match(es)" <+> msg,
+-- True <==> singular
+pp_context :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
+pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun
+  = vcat [text txt <+> msg,
           sep [ text "In" <+> ppr_match <> char ':'
               , nest 4 (rest_of_msg_fun pref)]]
   where
+    txt | singular  = "Pattern match"
+        | otherwise = "Pattern match(es)"
+
     (ppr_match, pref)
         = case kind of
              FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
diff --git a/testsuite/tests/deSugar/should_compile/T2395.stderr b/testsuite/tests/deSugar/should_compile/T2395.stderr
index a2ed232e78..fe6498d790 100644
--- a/testsuite/tests/deSugar/should_compile/T2395.stderr
+++ b/testsuite/tests/deSugar/should_compile/T2395.stderr
@@ -1,4 +1,4 @@
 
-T2395.hs:12:1: warning:
-    Pattern match(es) are redundant
+T2395.hs:13:1: warning:
+    Pattern match is redundant
     In an equation for ‘bar’: bar _ = ...
diff --git a/testsuite/tests/deSugar/should_compile/T5117.stderr b/testsuite/tests/deSugar/should_compile/T5117.stderr
index 954844d5f9..6ef44c81a3 100644
--- a/testsuite/tests/deSugar/should_compile/T5117.stderr
+++ b/testsuite/tests/deSugar/should_compile/T5117.stderr
@@ -1,4 +1,4 @@
 
-T5117.hs:15:1: Warning:
-    Pattern match(es) are redundant
+T5117.hs:16:1: warning:
+    Pattern match is redundant
     In an equation for ‘f3’: f3 (MyString "a") = ...
diff --git a/testsuite/tests/deSugar/should_compile/ds002.stderr b/testsuite/tests/deSugar/should_compile/ds002.stderr
index 3810c1b77b..c48e532621 100644
--- a/testsuite/tests/deSugar/should_compile/ds002.stderr
+++ b/testsuite/tests/deSugar/should_compile/ds002.stderr
@@ -1,10 +1,12 @@
 
-ds002.hs:7:1: Warning:
-    Pattern match(es) are redundant
-    In an equation for ‘f’:
-        f y = ...
-        f z = ...
+ds002.hs:8:1: warning:
+    Pattern match is redundant
+    In an equation for ‘f’: f y = ...
 
-ds002.hs:11:1: Warning:
-    Pattern match(es) are redundant
+ds002.hs:9:1: warning:
+    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 = ...
diff --git a/testsuite/tests/deSugar/should_compile/ds003.stderr b/testsuite/tests/deSugar/should_compile/ds003.stderr
index fdde26f10e..4851f56b71 100644
--- a/testsuite/tests/deSugar/should_compile/ds003.stderr
+++ b/testsuite/tests/deSugar/should_compile/ds003.stderr
@@ -1,6 +1,8 @@
 
-ds003.hs:5:1: Warning:
-    Pattern match(es) are redundant
-    In an equation for ‘f’:
-        f (x : x1 : x2 : x3) ~(y, ys) z = ...
-        f x y True = ...
+ds003.hs:7:1: warning:
+    Pattern match is redundant
+    In an equation for ‘f’: f (x : x1 : x2 : x3) ~(y, ys) z = ...
+
+ds003.hs:8:1: warning:
+    Pattern match is redundant
+    In an equation for ‘f’: f x y True = ...
diff --git a/testsuite/tests/deSugar/should_compile/ds019.stderr b/testsuite/tests/deSugar/should_compile/ds019.stderr
index 0a99306cd2..1761ad9606 100644
--- a/testsuite/tests/deSugar/should_compile/ds019.stderr
+++ b/testsuite/tests/deSugar/should_compile/ds019.stderr
@@ -1,7 +1,12 @@
 
-ds019.hs:5:1: Warning:
-    Pattern match(es) are redundant
-    In an equation for ‘f’:
-        f d (j, k) p = ...
-        f (e, f, g) l q = ...
-        f h (m, n) r = ...
+ds019.hs:6:1: warning:
+    Pattern match is redundant
+    In an equation for ‘f’: f d (j, k) p = ...
+
+ds019.hs:7:1: warning:
+    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 = ...
diff --git a/testsuite/tests/deSugar/should_compile/ds020.stderr b/testsuite/tests/deSugar/should_compile/ds020.stderr
index 8775bc6d6e..85abaa4e2a 100644
--- a/testsuite/tests/deSugar/should_compile/ds020.stderr
+++ b/testsuite/tests/deSugar/should_compile/ds020.stderr
@@ -1,18 +1,20 @@
 
-ds020.hs:8:1: Warning:
-    Pattern match(es) are redundant
+ds020.hs:9:1: warning:
+    Pattern match is redundant
     In an equation for ‘a’: a ~(~[], ~[], ~[]) = ...
 
-ds020.hs:11:1: Warning:
-    Pattern match(es) are redundant
+ds020.hs:12:1: warning:
+    Pattern match is redundant
     In an equation for ‘b’: b ~(~x : ~xs : ~ys) = ...
 
-ds020.hs:16:1: Warning:
-    Pattern match(es) are redundant
-    In an equation for ‘d’:
-        d ~(n+43) = ...
-        d ~(n+999) = ...
+ds020.hs:19:1: warning:
+    Pattern match is redundant
+    In an equation for ‘d’: d ~(n+43) = ...
 
-ds020.hs:22:1: Warning:
-    Pattern match(es) are redundant
+ds020.hs:20:1: warning:
+    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@(~[]) = ...
diff --git a/testsuite/tests/deSugar/should_compile/ds022.stderr b/testsuite/tests/deSugar/should_compile/ds022.stderr
index 17b62fee02..b5c33bfd5d 100644
--- a/testsuite/tests/deSugar/should_compile/ds022.stderr
+++ b/testsuite/tests/deSugar/should_compile/ds022.stderr
@@ -1,6 +1,8 @@
 
-ds022.hs:22:1: Warning:
-    Pattern match(es) are redundant
-    In an equation for ‘i’:
-        i 1 0.011e2 = ...
-        i 2 2.20000 = ...
+ds022.hs:24:1: warning:
+    Pattern match is redundant
+    In an equation for ‘i’: i 1 0.011e2 = ...
+
+ds022.hs:25:1: warning:
+    Pattern match is redundant
+    In an equation for ‘i’: i 2 2.20000 = ...
diff --git a/testsuite/tests/deSugar/should_compile/ds043.stderr b/testsuite/tests/deSugar/should_compile/ds043.stderr
index 0339745bab..c6fb861300 100644
--- a/testsuite/tests/deSugar/should_compile/ds043.stderr
+++ b/testsuite/tests/deSugar/should_compile/ds043.stderr
@@ -1,4 +1,4 @@
 
-ds043.hs:8:2: warning:
-    Pattern match(es) are redundant
+ds043.hs:10:3: warning:
+    Pattern match is redundant
     In a case alternative: B {e = True, f = False} -> ...
diff --git a/testsuite/tests/deSugar/should_compile/ds051.stderr b/testsuite/tests/deSugar/should_compile/ds051.stderr
index 4777dfcc2d..0cf4e1d34d 100644
--- a/testsuite/tests/deSugar/should_compile/ds051.stderr
+++ b/testsuite/tests/deSugar/should_compile/ds051.stderr
@@ -1,12 +1,12 @@
 
-ds051.hs:6:1: Warning:
-    Pattern match(es) are redundant
+ds051.hs:7:1: warning:
+    Pattern match is redundant
     In an equation for ‘f1’: f1 "ab" = ...
 
-ds051.hs:11:1: Warning:
-    Pattern match(es) are redundant
+ds051.hs:12:1: warning:
+    Pattern match is redundant
     In an equation for ‘f2’: f2 ('a' : 'b' : []) = ...
 
-ds051.hs:16:1: Warning:
-    Pattern match(es) are redundant
+ds051.hs:17:1: warning:
+    Pattern match is redundant
     In an equation for ‘f3’: f3 "ab" = ...
diff --git a/testsuite/tests/deSugar/should_compile/ds056.stderr b/testsuite/tests/deSugar/should_compile/ds056.stderr
index bcea3fdb07..4d605c7af7 100644
--- a/testsuite/tests/deSugar/should_compile/ds056.stderr
+++ b/testsuite/tests/deSugar/should_compile/ds056.stderr
@@ -1,4 +1,4 @@
 
-ds056.hs:8:1: warning:
-    Pattern match(es) are redundant
+ds056.hs:10:1: warning:
+    Pattern match is redundant
     In an equation for ‘g’: g _ = ...
diff --git a/testsuite/tests/deSugar/should_compile/ds058.stderr b/testsuite/tests/deSugar/should_compile/ds058.stderr
index 82f8141280..61aa219245 100644
--- a/testsuite/tests/deSugar/should_compile/ds058.stderr
+++ b/testsuite/tests/deSugar/should_compile/ds058.stderr
@@ -1,4 +1,4 @@
 
-ds058.hs:5:7: warning:
-    Pattern match(es) are redundant
+ds058.hs:7:9: warning:
+    Pattern match is redundant
     In a case alternative: Just _ -> ...
diff --git a/testsuite/tests/driver/werror.stderr b/testsuite/tests/driver/werror.stderr
index a20dc5e689..00240a07b3 100644
--- a/testsuite/tests/driver/werror.stderr
+++ b/testsuite/tests/driver/werror.stderr
@@ -19,12 +19,12 @@ werror.hs:10:1: warning:
       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:
     Pattern match(es) are non-exhaustive
     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: 
 Failing due to -Werror.
diff --git a/testsuite/tests/gadt/T7294.stderr b/testsuite/tests/gadt/T7294.stderr
index 94798403a5..a8ea17df80 100644
--- a/testsuite/tests/gadt/T7294.stderr
+++ b/testsuite/tests/gadt/T7294.stderr
@@ -1,12 +1,12 @@
-
-T7294.hs:23:1: warning:
-    Pattern match(es) are redundant
-    In an equation for ‘nth’: nth Nil _ = ...
-
-T7294.hs:25:5: warning:
-    • Couldn't match type ‘'True’ with ‘'False’
-      Inaccessible code in
-        a pattern with constructor: Nil :: forall a. Vec a 'Zero,
-        in an equation for ‘nth’
-    • In the pattern: Nil
-      In an equation for ‘nth’: nth Nil _ = undefined
+

+T7294.hs:25:1: warning:

+    Pattern match is redundant

+    In an equation for ‘nth’: nth Nil _ = ...

+

+T7294.hs:25:5: warning:

+    • Couldn't match type ‘'True’ with ‘'False’

+      Inaccessible code in

+        a pattern with constructor: Nil :: forall a. Vec a 'Zero,

+        in an equation for ‘nth’

+    • In the pattern: Nil

+      In an equation for ‘nth’: nth Nil _ = undefined

diff --git a/testsuite/tests/ghci/scripts/Defer02.stderr b/testsuite/tests/ghci/scripts/Defer02.stderr
index 29feadd24b..87171e0441 100644
--- a/testsuite/tests/ghci/scripts/Defer02.stderr
+++ b/testsuite/tests/ghci/scripts/Defer02.stderr
@@ -18,7 +18,7 @@
       In an equation for ‘b’: b x = x == x
 
 ../../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) = ...
 
 ../../typecheck/should_run/Defer01.hs:25:4: warning:
@@ -103,7 +103,7 @@
         k :: (Int ~ Bool) => Int -> Bool
 
 ../../typecheck/should_run/Defer01.hs:46:1: warning:
-    Pattern match(es) are redundant
+    Pattern match is redundant
     In an equation for ‘k’: k x = ...
 
 ../../typecheck/should_run/Defer01.hs:49:5: warning:
diff --git a/testsuite/tests/pmcheck/should_compile/pmc003.stderr b/testsuite/tests/pmcheck/should_compile/pmc003.stderr
index 4006b0c042..f1561730a3 100644
--- a/testsuite/tests/pmcheck/should_compile/pmc003.stderr
+++ b/testsuite/tests/pmcheck/should_compile/pmc003.stderr
@@ -1,3 +1,4 @@
-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 = ...
diff --git a/testsuite/tests/pmcheck/should_compile/pmc004.stderr b/testsuite/tests/pmcheck/should_compile/pmc004.stderr
index 53f590dd4e..37f85d5938 100644
--- a/testsuite/tests/pmcheck/should_compile/pmc004.stderr
+++ b/testsuite/tests/pmcheck/should_compile/pmc004.stderr
@@ -1,3 +1,4 @@
-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 = ...
diff --git a/testsuite/tests/pmcheck/should_compile/pmc005.stderr b/testsuite/tests/pmcheck/should_compile/pmc005.stderr
index 940dd3a1e9..ddb4af92ee 100644
--- a/testsuite/tests/pmcheck/should_compile/pmc005.stderr
+++ b/testsuite/tests/pmcheck/should_compile/pmc005.stderr
@@ -1,7 +1,8 @@
-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:
     Pattern match(es) are non-exhaustive
     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 = ...
diff --git a/testsuite/tests/th/TH_repUnboxedTuples.stderr b/testsuite/tests/th/TH_repUnboxedTuples.stderr
index 4ae798c5b4..bd647aba19 100644
--- a/testsuite/tests/th/TH_repUnboxedTuples.stderr
+++ b/testsuite/tests/th/TH_repUnboxedTuples.stderr
@@ -5,5 +5,5 @@ case (# 'b', GHC.Types.False #) of
     (# _, _ #) -> (# "Three", 3 #)
 
 TH_repUnboxedTuples.hs:18:13: warning:
-    Pattern match(es) are redundant
+    Pattern match is redundant
     In a case alternative: (# 'a', True #) -> ...
diff --git a/testsuite/tests/typecheck/should_compile/T5490.stderr b/testsuite/tests/typecheck/should_compile/T5490.stderr
index 7a32e9d7ad..4a2bb1f887 100644
--- a/testsuite/tests/typecheck/should_compile/T5490.stderr
+++ b/testsuite/tests/typecheck/should_compile/T5490.stderr
@@ -1,8 +1,8 @@
 
-T5490.hs:245:15: warning:
-    Pattern match(es) are redundant
+T5490.hs:246:5: warning:
+    Pattern match is redundant
     In a case alternative: HDropZero -> ...
 
-T5490.hs:288:3: warning:
-    Pattern match(es) are redundant
+T5490.hs:295:5: warning:
+    Pattern match is redundant
     In a case alternative: _ -> ...