Add long-distance info for pattern bindings (#18572)

We didn't consider the RHS of a pattern-binding before, which led to
surprising warnings listed in #18572.

As can be seen from the regression test T18572, we get the expected
output now.

11 files changed, 109 insertions, 72 deletions

diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs
index 8e54489f1e..5ce82fca7c 100644
--- a/compiler/GHC/HsToCore/Binds.hs
+++ b/compiler/GHC/HsToCore/Binds.hs
@@ -33,7 +33,7 @@ import {-# SOURCE #-}   GHC.HsToCore.Match ( matchWrapper )
 import GHC.HsToCore.Monad
 import GHC.HsToCore.GuardedRHSs
 import GHC.HsToCore.Utils
-import GHC.HsToCore.PmCheck ( addTyCsDs, checkGRHSs )
+import GHC.HsToCore.PmCheck ( addTyCsDs, covCheckGRHSs )
 
 import GHC.Hs             -- lots of things
 import GHC.Core           -- lots of things
@@ -184,7 +184,7 @@ dsHsBind dflags b@(FunBind { fun_id = L loc fun
 dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss
                          , pat_ext = ty
                          , pat_ticks = (rhs_tick, var_ticks) })
-  = do  { rhss_deltas <- checkGRHSs PatBindGuards grhss
+  = do  { rhss_deltas <- covCheckGRHSs PatBindGuards grhss
         ; body_expr <- dsGuarded grhss ty rhss_deltas
         ; let body' = mkOptTickBox rhs_tick body_expr
               pat'  = decideBangHood dflags pat
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index f15434e405..1f6841766c 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -31,7 +31,7 @@ import GHC.HsToCore.ListComp
 import GHC.HsToCore.Utils
 import GHC.HsToCore.Arrows
 import GHC.HsToCore.Monad
-import GHC.HsToCore.PmCheck ( addTyCsDs, checkGRHSs )
+import GHC.HsToCore.PmCheck ( addTyCsDs, covCheckGRHSs )
 import GHC.Types.Name
 import GHC.Types.Name.Env
 import GHC.Core.FamInstEnv( topNormaliseType )
@@ -215,7 +215,7 @@ dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss
                         , pat_ext = ty }) body
   =     -- let C x# y# = rhs in body
         -- ==> case rhs of C x# y# -> body
-    do { match_deltas <- checkGRHSs PatBindGuards grhss
+    do { match_deltas <- covCheckGRHSs PatBindGuards grhss
        ; rhs          <- dsGuarded grhss ty match_deltas
        ; let upat = unLoc pat
              eqn = EqnInfo { eqn_pats = [upat],
@@ -486,7 +486,7 @@ dsExpr (HsMultiIf res_ty alts)
 
   | otherwise
   = do { let grhss = GRHSs noExtField alts (noLoc emptyLocalBinds)
-       ; rhss_deltas  <- checkGRHSs IfAlt grhss
+       ; rhss_deltas  <- covCheckGRHSs IfAlt grhss
        ; match_result <- dsGRHSs IfAlt grhss res_ty rhss_deltas
        ; error_expr   <- mkErrorExpr
        ; extractMatchResult match_result error_expr }
@@ -986,7 +986,7 @@ dsDo ctx stmts
       = do  { body     <- goL stmts
             ; rhs'     <- dsLExpr rhs
             ; var   <- selectSimpleMatchVarL (xbstc_boundResultMult xbs) pat
-            ; match <- matchSinglePatVar var (StmtCtxt ctx) pat
+            ; match <- matchSinglePatVar var Nothing (StmtCtxt ctx) pat
                          (xbstc_boundResultType xbs) (cantFailMatchResult body)
             ; match_code <- dsHandleMonadicFailure ctx pat match (xbstc_failOp xbs)
             ; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] }
@@ -1007,7 +1007,7 @@ dsDo ctx stmts
 
            ; let match_args (pat, fail_op) (vs,body)
                    = do { var   <- selectSimpleMatchVarL Many pat
-                        ; match <- matchSinglePatVar var (StmtCtxt ctx) pat
+                        ; match <- matchSinglePatVar var Nothing (StmtCtxt ctx) pat
                                    body_ty (cantFailMatchResult body)
                         ; match_code <- dsHandleMonadicFailure ctx pat match fail_op
                         ; return (var:vs, match_code)
diff --git a/compiler/GHC/HsToCore/GuardedRHSs.hs b/compiler/GHC/HsToCore/GuardedRHSs.hs
index 6ff171febc..55ede1ddcb 100644
--- a/compiler/GHC/HsToCore/GuardedRHSs.hs
+++ b/compiler/GHC/HsToCore/GuardedRHSs.hs
@@ -36,7 +36,7 @@ import Control.Monad ( zipWithM )
 import Data.List.NonEmpty ( NonEmpty, toList )
 
 {-
-@dsGuarded@ is used for pattern bindings.
+@dsGuarded@ is used for GRHSs.
 It desugars:
 \begin{verbatim}
         | g1 -> e1
@@ -44,7 +44,7 @@ It desugars:
         | gn -> en
         where binds
 \end{verbatim}
-producing an expression with a runtime error in the corner if
+producing an expression with a runtime error in the corner case if
 necessary.  The type argument gives the type of the @ei@.
 -}
 
@@ -137,8 +137,8 @@ matchGuards (BindStmt _ pat bind_rhs : stmts) ctx deltas rhs rhs_ty = do
 
     match_result <- matchGuards stmts ctx deltas rhs rhs_ty
     core_rhs <- dsLExpr bind_rhs
-    match_result' <- matchSinglePatVar match_var (StmtCtxt ctx) pat rhs_ty
-                                       match_result
+    match_result' <- matchSinglePatVar match_var (Just core_rhs) (StmtCtxt ctx)
+                                       pat rhs_ty match_result
     pure $ bindNonRec match_var core_rhs <$> match_result'
 
 matchGuards (LastStmt  {} : _) _ _ _ _ = panic "matchGuards LastStmt"
diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs
index 0ecff073fc..19d46c1f2f 100644
--- a/compiler/GHC/HsToCore/ListComp.hs
+++ b/compiler/GHC/HsToCore/ListComp.hs
@@ -617,7 +617,7 @@ dsMcBindStmt :: LPat GhcTc
 dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts
   = do  { body     <- dsMcStmts stmts
         ; var      <- selectSimpleMatchVarL Many pat
-        ; match <- matchSinglePatVar var (StmtCtxt (DoExpr Nothing)) pat
+        ; match <- matchSinglePatVar var Nothing (StmtCtxt (DoExpr Nothing)) pat
                                   res1_ty (cantFailMatchResult body)
         ; match_code <- dsHandleMonadicFailure (MonadComp :: HsStmtContext GhcRn) pat match fail_op
         ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
index 98a27c97f3..75717c4bd9 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -66,7 +66,7 @@ import GHC.Data.FastString
 import GHC.Types.Unique
 import GHC.Types.Unique.DFM
 
-import Control.Monad(zipWithM,  unless )
+import Control.Monad ( zipWithM, unless, when )
 import Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.List.NonEmpty as NEL
 import qualified Data.Map as Map
@@ -769,9 +769,9 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
         -- @rhss_deltas@ is a flat list of covered Deltas for each RHS.
         -- Each Match will split off one Deltas for its RHSs from this.
         ; matches_deltas <- if isMatchContextPmChecked dflags origin ctxt
-            then addScrutTmCs mb_scr new_vars $
+            then addHsScrutTmCs mb_scr new_vars $
                  -- See Note [Type and Term Equality Propagation]
-                 checkMatches (DsMatchContext ctxt locn) new_vars matches
+                 covCheckMatchGroup (DsMatchContext ctxt locn) new_vars matches
             else pure (initDeltasMatches matches)
 
         ; eqns_info   <- zipWithM mk_eqn_info matches matches_deltas
@@ -820,25 +820,24 @@ matchEquations ctxt vars eqns_info rhs_ty
         ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc
         ; extractMatchResult match_result fail_expr }
 
-{-
-************************************************************************
-*                                                                      *
-\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}
-*                                                                      *
-************************************************************************
-
-@mkSimpleMatch@ is a wrapper for @match@ which deals with the
-situation where we want to match a single expression against a single
-pattern. It returns an expression.
--}
-
+-- | @matchSimply@ is a wrapper for 'match' which deals with the
+-- situation where we want to match a single expression against a single
+-- pattern. It returns an expression.
 matchSimply :: CoreExpr                 -- ^ Scrutinee
             -> HsMatchContext GhcRn     -- ^ Match kind
             -> LPat GhcTc               -- ^ Pattern it should match
             -> CoreExpr                 -- ^ Return this if it matches
             -> CoreExpr                 -- ^ Return this if it doesn't
             -> DsM CoreExpr
--- Do not warn about incomplete patterns; see matchSinglePat comments
+-- Some reasons 'matchSimply' is not defined using 'matchWrapper' (#18572):
+--   * Some call sites like in 'deBindComp' specify a @fail_expr@ that isn't a
+--     straight @patError@
+--   * It receives an already desugared 'CoreExpr' for the scrutinee, not an
+--     'HsExpr' like 'matchWrapper' expects
+--   * Filling in all the phony fields for the 'MatchGroup' for a single pattern
+--     match is awkward
+--   * And we still export 'matchSinglePatVar', so not much is gained if we
+--     don't also implement it in terms of 'matchWrapper'
 matchSimply scrut hs_ctx pat result_expr fail_expr = do
     let
       match_result = cantFailMatchResult result_expr
@@ -858,7 +857,7 @@ matchSinglePat :: CoreExpr -> HsMatchContext GhcRn -> LPat GhcTc
 
 matchSinglePat (Var var) ctx pat ty match_result
   | not (isExternalName (idName var))
-  = matchSinglePatVar var ctx pat ty match_result
+  = matchSinglePatVar var Nothing ctx pat ty match_result
 
 matchSinglePat scrut hs_ctx pat ty match_result
   = do { var           <- selectSimpleMatchVarL Many pat
@@ -867,22 +866,22 @@ matchSinglePat scrut hs_ctx pat ty match_result
                             -- and to create field selectors. All of which only
                             -- bind unrestricted variables, hence the 'Many'
                             -- above.
-       ; match_result' <- matchSinglePatVar var hs_ctx pat ty match_result
+       ; match_result' <- matchSinglePatVar var (Just scrut) hs_ctx pat ty match_result
        ; return $ bindNonRec var scrut <$> match_result'
        }
 
 matchSinglePatVar :: Id   -- See Note [Match Ids]
+                  -> Maybe CoreExpr -- ^ The scrutinee the match id is bound to
                   -> HsMatchContext GhcRn -> LPat GhcTc
                   -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
-matchSinglePatVar var ctx pat ty match_result
+matchSinglePatVar var mb_scrut ctx pat ty match_result
   = ASSERT2( isInternalName (idName var), ppr var )
     do { dflags <- getDynFlags
        ; locn   <- getSrcSpanDs
-
        -- Pattern match check warnings
-       ; if isMatchContextPmChecked dflags FromSource ctx
-            then checkSingle dflags (DsMatchContext ctx locn) var (unLoc pat)
-            else pure ()
+       ; when (isMatchContextPmChecked dflags FromSource ctx) $
+           addCoreScrutTmCs mb_scrut [var] $
+           covCheckPatBind dflags (DsMatchContext ctx locn) var (unLoc pat)
 
        ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]
                                 , eqn_orig = FromSource
diff --git a/compiler/GHC/HsToCore/Match.hs-boot b/compiler/GHC/HsToCore/Match.hs-boot
index b42c84e10a..3014c069a5 100644
--- a/compiler/GHC/HsToCore/Match.hs-boot
+++ b/compiler/GHC/HsToCore/Match.hs-boot
@@ -29,6 +29,7 @@ matchSimply
 
 matchSinglePatVar
         :: Id
+        -> Maybe CoreExpr
         -> HsMatchContext GhcRn
         -> LPat GhcTc
         -> Type
diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs
index 31ac10f0a0..6ba760369b 100644
--- a/compiler/GHC/HsToCore/PmCheck.hs
+++ b/compiler/GHC/HsToCore/PmCheck.hs
@@ -14,11 +14,11 @@ Pattern Matching Coverage Checking.
 
 module GHC.HsToCore.PmCheck (
         -- Checking and printing
-        checkSingle, checkMatches, checkGRHSs,
+        covCheckPatBind, covCheckMatchGroup, covCheckGRHSs,
         isMatchContextPmChecked,
 
         -- See Note [Type and Term Equality Propagation]
-        addTyCsDs, addScrutTmCs
+        addTyCsDs, addCoreScrutTmCs, addHsScrutTmCs
     ) where
 
 #include "HsVersions.h"
@@ -283,37 +283,38 @@ instance Outputable CheckResult where
 {-
 %************************************************************************
 %*                                                                      *
-       Entry points to the checker: checkSingle and checkMatches
+       Entry points to the checker: covCheckPatBind and covCheckMatchGroup
 %*                                                                      *
 %************************************************************************
 -}
 
--- | Check a single pattern binding (let) for exhaustiveness.
-checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat GhcTc -> DsM ()
-checkSingle dflags ctxt@(DsMatchContext kind locn) var p = do
-  tracePm "checkSingle" (vcat [ppr ctxt, ppr var, ppr p])
+-- | Check a pattern binding (let, where) for exhaustiveness.
+covCheckPatBind :: DynFlags -> DsMatchContext -> Id -> Pat GhcTc -> DsM ()
+covCheckPatBind dflags ctxt@(DsMatchContext _ locn) var p = do
   -- We only ever need to run this in a context where we need exhaustivity
   -- warnings (so not in pattern guards or comprehensions, for example, because
   -- they are perfectly fine to fail).
   -- Omitting checking this flag emits redundancy warnings twice in obscure
   -- cases like #17646.
-  when (exhaustive dflags kind) $ do
-    -- TODO: This could probably call checkMatches, like checkGRHSs.
-    missing   <- getPmDeltas
-    tracePm "checkSingle: missing" (ppr missing)
-    fam_insts <- dsGetFamInstEnvs
-    grd_tree  <- mkGrdTreeRhs (L locn $ ppr p) <$> translatePat fam_insts var p
-    res <- checkGrdTree grd_tree missing
-    dsPmWarn dflags ctxt [var] res
+  -- Given the context in which this function is called, it will only ever do
+  -- something for
+  --   * PatBindRhs, -Wincomplete-uni-patterns: @let True = False@
+  --   * PatBindGuards, -Wincomplete-patterns: @Just x | False = Just 42@
+  missing   <- getPmDeltas
+  tracePm "covCheckPatBind" (vcat [ppr ctxt, ppr var, ppr p, ppr missing])
+  fam_insts <- dsGetFamInstEnvs
+  grd_tree  <- mkGrdTreeRhs (L locn $ ppr p) <$> translatePat fam_insts var p
+  res <- checkGrdTree grd_tree missing
+  dsPmWarn dflags ctxt [var] res
 
 -- | Exhaustive for guard matches, is used for guards in pattern bindings and
 -- in @MultiIf@ expressions. Returns the 'Deltas' covered by the RHSs.
-checkGRHSs
+covCheckGRHSs
   :: HsMatchContext GhcRn         -- ^ Match context, for warning messages
   -> GRHSs GhcTc (LHsExpr GhcTc)  -- ^ The GRHSs to check
   -> DsM (NonEmpty Deltas)        -- ^ Covered 'Deltas' for each RHS, for long
                                   --   distance info
-checkGRHSs hs_ctx guards@(GRHSs _ grhss _) = do
+covCheckGRHSs hs_ctx guards@(GRHSs _ grhss _) = do
     let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss)
         dsMatchContext = DsMatchContext hs_ctx combinedLoc
         match = L combinedLoc $
@@ -321,7 +322,7 @@ checkGRHSs hs_ctx guards@(GRHSs _ grhss _) = do
                         , m_ctxt = hs_ctx
                         , m_pats = []
                         , m_grhss = guards }
-    [(_, deltas)] <- checkMatches dsMatchContext [] [match]
+    [(_, deltas)] <- covCheckMatchGroup dsMatchContext [] [match]
     pure deltas
 
 -- | Check a list of syntactic /match/es (part of case, functions, etc.), each
@@ -337,14 +338,14 @@ checkGRHSs hs_ctx guards@(GRHSs _ grhss _) = do
 -- incoming uncovered 'Deltas' (from 'getPmDeltas') if the GRHS is inaccessible.
 -- Since there is at least one /grhs/ per /match/, the list of 'Deltas' is at
 -- least as long as the list of matches.
-checkMatches
+covCheckMatchGroup
   :: DsMatchContext                  -- ^ Match context, for warnings messages
   -> [Id]                            -- ^ Match variables, i.e. x and y above
   -> [LMatch GhcTc (LHsExpr GhcTc)]  -- ^ List of matches
   -> DsM [(Deltas, NonEmpty Deltas)] -- ^ One covered 'Deltas' per RHS, for long
                                      --   distance info.
-checkMatches ctxt vars matches = do
-  tracePm "checkMatches" (hang (vcat [ppr ctxt
+covCheckMatchGroup ctxt vars matches = do
+  tracePm "covCheckMatchGroup" (hang (vcat [ppr ctxt
                                , ppr vars
                                , text "Matches:"])
                                2
@@ -1112,7 +1113,7 @@ f x = case x of
              (_:_) -> True
              []    -> False -- can't happen
 
-Functions `addScrutTmCs' is responsible for generating
+Functions `add*ScrutTmCs' is responsible for generating
 these constraints.
 -}
 
@@ -1141,17 +1142,24 @@ addTyCsDs origin ev_vars m = do
             (locallyExtendPmDelta (\deltas -> addPmCtsDeltas deltas (PmTyCt . evVarPred <$> ev_vars)))
             m
 
--- | Add equalities for the scrutinee to the local 'DsM' environment when
--- checking a case expression:
+-- | Add equalities for the 'CoreExpr' scrutinee to the local 'DsM' environment
+-- when checking a case expression:
 --     case e of x { matches }
 -- When checking matches we record that (x ~ e) where x is the initial
 -- uncovered. All matches will have to satisfy this equality.
-addScrutTmCs :: Maybe (LHsExpr GhcTc) -> [Id] -> DsM a -> DsM a
-addScrutTmCs Nothing    _   k = k
-addScrutTmCs (Just scr) [x] k = do
+addCoreScrutTmCs :: Maybe CoreExpr -> [Id] -> DsM a -> DsM a
+addCoreScrutTmCs Nothing    _   k = k
+addCoreScrutTmCs (Just scr) [x] k =
+  flip locallyExtendPmDelta k $ \deltas ->
+    addPmCtsDeltas deltas (unitBag (PmCoreCt x scr))
+addCoreScrutTmCs _   _   _ = panic "addCoreScrutTmCs: scrutinee, but more than one match id"
+
+-- | 'addCoreScrutTmCs', but desugars the 'LHsExpr' first.
+addHsScrutTmCs :: Maybe (LHsExpr GhcTc) -> [Id] -> DsM a -> DsM a
+addHsScrutTmCs Nothing    _    k = k
+addHsScrutTmCs (Just scr) vars k = do
   scr_e <- dsLExpr scr
-  locallyExtendPmDelta (\deltas -> addPmCtsDeltas deltas (unitBag (PmCoreCt x scr_e))) k
-addScrutTmCs _   _   _ = panic "addScrutTmCs: HsCase with more than one case binder"
+  addCoreScrutTmCs (Just scr_e) vars k
 
 {-
 %************************************************************************
@@ -1169,7 +1177,7 @@ isMatchContextPmChecked dflags origin kind
   | isGenerated origin
   = False
   | otherwise
-  = wopt Opt_WarnOverlappingPatterns dflags || exhaustive dflags kind
+  = overlapping dflags kind || exhaustive dflags kind
 
 -- | Return True when any of the pattern match warnings ('allPmCheckWarnings')
 -- are enabled, in which case we need to run the pattern match checker.
@@ -1399,10 +1407,9 @@ 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
+-- Don't warn about incomplete patterns in list comprehensions, pattern guards
+-- etc. They are often *supposed* to be incomplete
+exhaustiveWarningFlag (StmtCtxt {}) = Nothing
 
 -- True <==> singular
 pprContext :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
diff --git a/compiler/GHC/HsToCore/PmCheck/Oracle.hs b/compiler/GHC/HsToCore/PmCheck/Oracle.hs
index bf21c8594b..9a3c312a2e 100644
--- a/compiler/GHC/HsToCore/PmCheck/Oracle.hs
+++ b/compiler/GHC/HsToCore/PmCheck/Oracle.hs
@@ -1265,7 +1265,7 @@ isTyConTriviallyInhabited tc = elementOfUniqSet tc triviallyInhabitedTyCons
 {- Note [Checking EmptyCase Expressions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Empty case expressions are strict on the scrutinee. That is, `case x of {}`
-will force argument `x`. Hence, `checkMatches` is not sufficient for checking
+will force argument `x`. Hence, `covCheckMatchGroup` is not sufficient for checking
 empty cases, because it assumes that the match is not strict (which is true
 for all other cases, apart from EmptyCase). This gave rise to #10746. Instead,
 we do the following:
diff --git a/testsuite/tests/pmcheck/should_compile/T18572.hs b/testsuite/tests/pmcheck/should_compile/T18572.hs
new file mode 100644
index 0000000000..9a37de4813
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T18572.hs
@@ -0,0 +1,12 @@
+{-# OPTIONS_GHC -Wincomplete-uni-patterns -Wincomplete-patterns -fforce-recomp #-}
+{-# LANGUAGE DataKinds, KindSignatures, GADTs #-}
+
+module T18572 where
+
+True = True
+
+data SBool (b :: Bool) where
+  STrue :: SBool True
+  SFalse :: SBool False
+
+STrue = SFalse
diff --git a/testsuite/tests/pmcheck/should_compile/T18572.stderr b/testsuite/tests/pmcheck/should_compile/T18572.stderr
new file mode 100644
index 0000000000..15d9f7c5b5
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T18572.stderr
@@ -0,0 +1,16 @@
+
+T18572.hs:12:1: warning: [-Winaccessible-code (in -Wdefault)]
+    • Couldn't match type ‘'False’ with ‘'True’
+      Inaccessible code in
+        a pattern with constructor: STrue :: SBool 'True,
+        in a pattern binding
+    • In the pattern: STrue
+      In a pattern binding: STrue = SFalse
+
+T18572.hs:12:1: warning: [-Woverlapping-patterns (in -Wdefault)]
+    Pattern match is redundant
+    In a pattern binding: STrue = ...
+
+T18572.hs:12:1: warning: [-Wincomplete-uni-patterns]
+    Pattern match(es) are non-exhaustive
+    In a pattern binding: Patterns not matched: SFalse
diff --git a/testsuite/tests/pmcheck/should_compile/all.T b/testsuite/tests/pmcheck/should_compile/all.T
index 51fb76b078..ee69cf176a 100644
--- a/testsuite/tests/pmcheck/should_compile/all.T
+++ b/testsuite/tests/pmcheck/should_compile/all.T
@@ -102,6 +102,8 @@ test('T17234', normal, compile,
      ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
 test('T17248', normal, compile,
      ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
+test('T17340', normal, compile,
+     ['-Wredundant-bang-patterns'])
 test('T17357', expect_broken(17357), compile,
      ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
 test('T17376', normal, compile,
@@ -124,8 +126,8 @@ test('T18478', collect_compiler_stats('bytes allocated',10), compile,
      ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
 test('T18533', normal, compile,
      ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
-test('T17340', normal, compile,
-     ['-Wredundant-bang-patterns'])
+test('T18572', normal, compile,
+     ['-fwarn-incomplete-patterns -fwarn-incomplete-uni-patterns -fwarn-overlapping-patterns'])
 
 # Other tests
 test('pmc001', [], compile,