summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSebastian Graf <sebastian.graf@kit.edu>2020-08-12 18:35:28 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-09-10 10:35:33 -0400
commit67ce72da1689058cb689ffbb6fcbd5cd12af56df (patch)
tree694ee73ed29fc5953b1cc2f57c72f0761c8ad5dc
parent4798caa0fefd7adf4c5b85fa84a6f28fcc6b350b (diff)
downloadhaskell-67ce72da1689058cb689ffbb6fcbd5cd12af56df.tar.gz
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.
-rw-r--r--compiler/GHC/HsToCore/Binds.hs4
-rw-r--r--compiler/GHC/HsToCore/Expr.hs10
-rw-r--r--compiler/GHC/HsToCore/GuardedRHSs.hs8
-rw-r--r--compiler/GHC/HsToCore/ListComp.hs2
-rw-r--r--compiler/GHC/HsToCore/Match.hs45
-rw-r--r--compiler/GHC/HsToCore/Match.hs-boot1
-rw-r--r--compiler/GHC/HsToCore/PmCheck.hs75
-rw-r--r--compiler/GHC/HsToCore/PmCheck/Oracle.hs2
-rw-r--r--testsuite/tests/pmcheck/should_compile/T18572.hs12
-rw-r--r--testsuite/tests/pmcheck/should_compile/T18572.stderr16
-rw-r--r--testsuite/tests/pmcheck/should_compile/all.T6
11 files changed, 109 insertions, 72 deletions
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs
index c8b4087958..f900d45c55 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
@@ -185,7 +185,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 732f86cbdf..659f8da7e7 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 }
@@ -981,7 +981,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] }
@@ -1002,7 +1002,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 04bff18be1..f607231d18 100644
--- a/compiler/GHC/HsToCore/PmCheck/Oracle.hs
+++ b/compiler/GHC/HsToCore/PmCheck/Oracle.hs
@@ -1266,7 +1266,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,