diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index a776abe0767ef039b72a4d5c112fdfa2737efac9..ba6415402a9e2fcf3b2539ef97aaabc24e3952b6 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -24,7 +24,6 @@ import GhcPrelude
import TmOracle
import Unify( tcMatchTy )
-import BasicTypes
import DynFlags
import HsSyn
import TcHsSyn
@@ -45,7 +44,7 @@ import HscTypes (CompleteMatch(..))
import DsMonad
import TcSimplify (tcCheckSatisfiability)
-import TcType (isStringTy, isIntTy, isWordTy)
+import TcType (isStringTy)
import Bag
import ErrUtils
import Var (EvVar)
@@ -54,7 +53,6 @@ import Type
import UniqSupply
import DsGRHSs (isTrueLHsExpr)
import Maybes (expectJust)
-import qualified GHC.LanguageExtensions as LangExt
import Data.List (find)
import Data.Maybe (catMaybes, isJust, fromMaybe)
@@ -790,31 +788,18 @@ translatePat fam_insts pat = case pat of
<$> translatePatVec fam_insts (map unLoc ps)
-- overloaded list
- ListPat (ListPatTc _elem_ty (Just (pat_ty, _to_list))) lpats -> do
- dflags <- getDynFlags
- if xopt LangExt.RebindableSyntax dflags
- then mkCanFailPmPat pat_ty
- else case splitListTyConApp_maybe pat_ty of
- Just e_ty -> translatePat fam_insts
- (ListPat (ListPatTc e_ty Nothing) lpats)
- Nothing -> mkCanFailPmPat pat_ty
- -- (a) In the presence of RebindableSyntax, we don't know anything about
- -- `toList`, we should treat `ListPat` as any other view pattern.
- --
- -- (b) In the absence of RebindableSyntax,
- -- - If the pat_ty is `[a]`, then we treat the overloaded list pattern
- -- as ordinary list pattern. Although we can give an instance
- -- `IsList [Int]` (more specific than the default `IsList [a]`), in
- -- practice, we almost never do that. We assume the `_to_list` is
- -- the `toList` from `instance IsList [a]`.
- --
- -- - Otherwise, we treat the `ListPat` as ordinary view pattern.
- --
- -- See Trac #14547, especially comment#9 and comment#10.
- --
- -- Here we construct CanFailPmPat directly, rather can construct a view
- -- pattern and do further translation as an optimization, for the reason,
- -- see Note [Guards and Approximation].
+ ListPat (ListPatTc elem_ty (Just (pat_ty, _to_list))) lpats
+ | Just e_ty <- splitListTyConApp_maybe pat_ty
+ , (_, norm_elem_ty) <- normaliseType fam_insts Nominal elem_ty
+ -- elem_ty is frequently something like
+ -- `Item [Int]`, but we prefer `Int`
+ , norm_elem_ty `eqType` e_ty ->
+ -- We have to ensure that the element types are exactly the same.
+ -- Otherwise, one may give an instance IsList [Int] (more specific than
+ -- the default IsList [a]) with a different implementation for `toList'
+ translatePat fam_insts (ListPat (ListPatTc e_ty Nothing) lpats)
+ -- See Note [Guards and Approximation]
+ | otherwise -> mkCanFailPmPat pat_ty
ConPatOut { pat_con = L _ con
, pat_arg_tys = arg_tys
@@ -832,14 +817,21 @@ translatePat fam_insts pat = case pat of
, pm_con_dicts = dicts
, pm_con_args = args }]
- NPat ty (L _ ol) mb_neg _eq -> translateNPat fam_insts ol mb_neg ty
+ -- See Note [Translate Overloaded Literal for Exhaustiveness Checking]
+ NPat _ (L _ olit) mb_neg _
+ | OverLit (OverLitTc False ty) (HsIsString src s) _ <- olit
+ , isStringTy ty ->
+ foldr (mkListPatVec charTy) [nilPattern charTy] <$>
+ translatePatVec fam_insts
+ (map (LitPat noExt . HsChar src) (unpackFS s))
+ | otherwise -> return [PmLit { pm_lit_lit = PmOLit (isJust mb_neg) olit }]
+ -- See Note [Translate Overloaded Literal for Exhaustiveness Checking]
LitPat _ lit
- -- If it is a string then convert it to a list of characters
| HsString src s <- lit ->
foldr (mkListPatVec charTy) [nilPattern charTy] <$>
translatePatVec fam_insts
- (map (LitPat noExt . HsChar src) (unpackFS s))
+ (map (LitPat noExt . HsChar src) (unpackFS s))
| otherwise -> return [mkLitPattern lit]
TuplePat tys ps boxity -> do
@@ -858,29 +850,90 @@ translatePat fam_insts pat = case pat of
SplicePat {} -> panic "Check.translatePat: SplicePat"
XPat {} -> panic "Check.translatePat: XPat"
--- | Translate an overloaded literal (see `tidyNPat' in deSugar/MatchLit.hs)
-translateNPat :: FamInstEnvs
- -> HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> Type
- -> DsM PatVec
-translateNPat fam_insts (OverLit (OverLitTc False ty) val _ ) mb_neg outer_ty
- | not type_change, isStringTy ty, HsIsString src s <- val, Nothing <- mb_neg
- = translatePat fam_insts (LitPat noExt (HsString src s))
- | not type_change, isIntTy ty, HsIntegral i <- val
- = translatePat fam_insts
- (LitPat noExt $ case mb_neg of
- Nothing -> HsInt noExt i
- Just _ -> HsInt noExt (negateIntegralLit i))
- | not type_change, isWordTy ty, HsIntegral i <- val
- = translatePat fam_insts
- (LitPat noExt $ case mb_neg of
- Nothing -> HsWordPrim (il_text i) (il_value i)
- Just _ -> let ni = negateIntegralLit i in
- HsWordPrim (il_text ni) (il_value ni))
- where
- type_change = not (outer_ty `eqType` ty)
-
-translateNPat _ ol mb_neg _
- = return [PmLit { pm_lit_lit = PmOLit (isJust mb_neg) ol }]
+{- Note [Translate Overloaded Literal for Exhaustiveness Checking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The translation of @NPat@ in exhaustiveness checker is a bit different
+from translation in pattern matcher.
+
+ * In pattern matcher (see `tidyNPat' in deSugar/MatchLit.hs), we
+ translate integral literals to HsIntPrim or HsWordPrim and translate
+ overloaded strings to HsString.
+
+ * In exhaustiveness checker, in `genCaseTmCs1/genCaseTmCs2`, we use
+ `lhsExprToPmExpr` to generate uncovered set. In `hsExprToPmExpr`,
+ however we generate `PmOLit` for HsOverLit, rather than refine
+ `HsOverLit` inside `NPat` to HsIntPrim/HsWordPrim. If we do
+ the same thing in `translatePat` as in `tidyNPat`, the exhaustiveness
+ checker will fail to match the literals patterns correctly. See
+ Trac #14546.
+
+ In Note [Undecidable Equality for Overloaded Literals], we say: "treat
+ overloaded literals that look different as different", but previously we
+ didn't do such things.
+
+ Now, we translate the literal value to match and the literal patterns
+ consistently:
+
+ * For integral literals, we parse both the integral literal value and
+ the patterns as OverLit HsIntegral. For example:
+
+ case 0::Int of
+ 0 -> putStrLn "A"
+ 1 -> putStrLn "B"
+ _ -> putStrLn "C"
+
+ When checking the exhaustiveness of pattern matching, we translate the 0
+ in value position as PmOLit, but translate the 0 and 1 in pattern position
+ as PmSLit. The inconsistency leads to the failure of eqPmLit to detect the
+ equality and report warning of "Pattern match is redundant" on pattern 0,
+ as reported in Trac #14546. In this patch we remove the specialization of
+ OverLit patterns, and keep the overloaded number literal in pattern as it
+ is to maintain the consistency. We know nothing about the `fromInteger`
+ method (see Note [Undecidable Equality for Overloaded Literals]). Now we
+ can capture the exhaustiveness of pattern 0 and the redundancy of pattern
+ 1 and _.
+
+ * For string literals, we parse the string literals as HsString. When
+ OverloadedStrings is enabled, it further be turned as HsOverLit HsIsString.
+ For example:
+
+ case "foo" of
+ "foo" -> putStrLn "A"
+ "bar" -> putStrLn "B"
+ "baz" -> putStrLn "C"
+
+ Previously, the overloaded string values are translated to PmOLit and the
+ non-overloaded string values are translated to PmSLit. However the string
+ patterns, both overloaded and non-overloaded, are translated to list of
+ characters. The inconsistency leads to wrong warnings about redundant and
+ non-exhaustive pattern matching warnings, as reported in Trac #14546.
+
+ In order to catch the redundant pattern in following case:
+
+ case "foo" of
+ ('f':_) -> putStrLn "A"
+ "bar" -> putStrLn "B"
+
+ in this patch, we translate non-overloaded string literals, both in value
+ position and pattern position, as list of characters. For overloaded string
+ literals, we only translate it to list of characters only when it's type
+ is stringTy, since we know nothing about the toString methods. But we know
+ that if two overloaded strings are syntax equal, then they are equal. Then
+ if it's type is not stringTy, we just translate it to PmOLit. We can still
+ capture the exhaustiveness of pattern "foo" and the redundancy of pattern
+ "bar" and "baz" in the following code:
+
+ {-# LANGUAGE OverloadedStrings #-}
+ main = do
+ case "foo" of
+ "foo" -> putStrLn "A"
+ "bar" -> putStrLn "B"
+ "baz" -> putStrLn "C"
+
+ We must ensure that doing the same translation to literal values and patterns
+ in `translatePat` and `hsExprToPmExpr`. The previous inconsistent work led to
+ Trac #14546.
+-}
-- | Translate a list of patterns (Note: each pattern is translated
-- to a pattern vector but we do not concatenate the results).
@@ -1096,7 +1149,7 @@ below is the *right thing to do*:
The case with literals is a bit different. a literal @l@ should be translated
to @x (True <- x == from l)@. Since we want to have better warnings for
overloaded literals as it is a very common feature, we treat them differently.
-They are mainly covered in Note [Undecidable Equality on Overloaded Literals]
+They are mainly covered in Note [Undecidable Equality for Overloaded Literals]
in PmExpr.
4. N+K Patterns & Pattern Synonyms
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index fabbe2bc2f18126a8d1cfc4984cfd51de6326fb3..ec831acdb1dd0c00a5581fd9f967dccba20b9d06 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -465,7 +465,7 @@ tidy1 _ (LitPat _ lit)
-- NPats: we *might* be able to replace these w/ a simpler form
tidy1 _ (NPat ty (L _ lit) mb_neg eq)
- = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq ty)
+ = return (idDsWrapper, tidyNPat lit mb_neg eq ty)
-- Everything else goes through unchanged...
diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs
index c7bff64ff3dff752a611f8f79c9a094eba71b9ab..d715439015cfe34002c9a0c32ca70fd46fe29cf2 100644
--- a/compiler/deSugar/MatchLit.hs
+++ b/compiler/deSugar/MatchLit.hs
@@ -278,15 +278,10 @@ tidyLitPat (HsString src s)
tidyLitPat lit = LitPat noExt lit
----------------
-tidyNPat :: (HsLit GhcTc -> Pat GhcTc) -- How to tidy a LitPat
- -- We need this argument because tidyNPat is called
- -- both by Match and by Check, but they tidy LitPats
- -- slightly differently; and we must desugar
- -- literals consistently (see Trac #5117)
- -> HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc
+tidyNPat :: HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc
-> Type
-> Pat GhcTc
-tidyNPat tidy_lit_pat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty
+tidyNPat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty
-- False: Take short cuts only if the literal is not using rebindable syntax
--
-- Once that is settled, look for cases where the type of the
@@ -302,7 +297,7 @@ tidyNPat tidy_lit_pat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty
| not type_change, isWordTy ty, Just int_lit <- mb_int_lit
= mk_con_pat wordDataCon (HsWordPrim NoSourceText int_lit)
| not type_change, isStringTy ty, Just str_lit <- mb_str_lit
- = tidy_lit_pat (HsString NoSourceText str_lit)
+ = tidyLitPat (HsString NoSourceText str_lit)
-- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3
-- If we do convert to the constructor form, we'll generate a case
-- expression on a Float# or Double# and that's not allowed in Core; see
@@ -329,7 +324,7 @@ tidyNPat tidy_lit_pat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty
(Nothing, HsIsString _ s) -> Just s
_ -> Nothing
-tidyNPat _ over_lit mb_neg eq outer_ty
+tidyNPat over_lit mb_neg eq outer_ty
= NPat outer_ty (noLoc over_lit) mb_neg eq
{-
diff --git a/compiler/deSugar/PmExpr.hs b/compiler/deSugar/PmExpr.hs
index 56d310f618be133ffaa666789df20d52bf472d3c..fbacb989a1e7cc7502ce1b1ed6592eb8ace53a13 100644
--- a/compiler/deSugar/PmExpr.hs
+++ b/compiler/deSugar/PmExpr.hs
@@ -17,12 +17,15 @@ module PmExpr (
import GhcPrelude
+import BasicTypes (SourceText)
+import FastString (FastString, unpackFS)
import HsSyn
import Id
import Name
import NameSet
import DataCon
import ConLike
+import TcType (isStringTy)
import TysWiredIn
import Outputable
import Util
@@ -238,13 +241,27 @@ hsExprToPmExpr :: HsExpr GhcTc -> PmExpr
hsExprToPmExpr (HsVar _ x) = PmExprVar (idName (unLoc x))
hsExprToPmExpr (HsConLikeOut _ c) = PmExprVar (conLikeName c)
-hsExprToPmExpr (HsOverLit _ olit) = PmExprLit (PmOLit False olit)
-hsExprToPmExpr (HsLit _ lit) = PmExprLit (PmSLit lit)
-hsExprToPmExpr e@(NegApp _ _ neg_e)
- | PmExprLit (PmOLit False ol) <- synExprToPmExpr neg_e
- = PmExprLit (PmOLit True ol)
+-- Desugar literal strings as a list of characters. For other literal values,
+-- keep it as it is.
+-- See `translatePat` in Check.hs (the `NPat` and `LitPat` case), and
+-- Note [Translate Overloaded Literal for Exhaustiveness Checking].
+hsExprToPmExpr (HsOverLit _ olit)
+ | OverLit (OverLitTc False ty) (HsIsString src s) _ <- olit, isStringTy ty
+ = stringExprToList src s
+ | otherwise = PmExprLit (PmOLit False olit)
+hsExprToPmExpr (HsLit _ lit)
+ | HsString src s <- lit
+ = stringExprToList src s
+ | otherwise = PmExprLit (PmSLit lit)
+
+hsExprToPmExpr e@(NegApp _ (L _ neg_expr) _)
+ | PmExprLit (PmOLit False olit) <- hsExprToPmExpr neg_expr
+ -- NB: DON'T simply @(NegApp (NegApp olit))@ as @x@. when extension
+ -- @RebindableSyntax@ enabled, (-(-x)) may not equals to x.
+ = PmExprLit (PmOLit True olit)
| otherwise = PmExprOther e
+
hsExprToPmExpr (HsPar _ (L _ e)) = hsExprToPmExpr e
hsExprToPmExpr e@(ExplicitTuple _ ps boxity)
@@ -279,8 +296,12 @@ hsExprToPmExpr (ExprWithTySig _ e) = lhsExprToPmExpr e
hsExprToPmExpr (HsWrap _ _ e) = hsExprToPmExpr e
hsExprToPmExpr e = PmExprOther e -- the rest are not handled by the oracle
-synExprToPmExpr :: SyntaxExpr GhcTc -> PmExpr
-synExprToPmExpr = hsExprToPmExpr . syn_expr -- ignore the wrappers
+stringExprToList :: SourceText -> FastString -> PmExpr
+stringExprToList src s = foldr cons nil (map charToPmExpr (unpackFS s))
+ where
+ cons x xs = mkPmExprData consDataCon [x,xs]
+ nil = mkPmExprData nilDataCon []
+ charToPmExpr c = PmExprLit (PmSLit (HsChar src c))
{-
%************************************************************************
diff --git a/testsuite/tests/deSugar/should_compile/T14546a.hs b/testsuite/tests/deSugar/should_compile/T14546a.hs
new file mode 100644
index 0000000000000000000000000000000000000000..085ea3ced9898e8f99914f804ea8fa1bfadf9441
--- /dev/null
+++ b/testsuite/tests/deSugar/should_compile/T14546a.hs
@@ -0,0 +1,29 @@
+main :: IO ()
+main = do
+ case 0::Int of
+ 0 -> putStrLn "A"
+ 1 -> putStrLn "B"
+ _ -> putStrLn "C"
+
+ case 0::Int of
+ 0 -> putStrLn "A"
+ 1 -> putStrLn "B"
+ 2 -> putStrLn "C"
+
+ case 0::Integer of
+ 0 -> putStrLn "A"
+ 1 -> putStrLn "B"
+ _ -> putStrLn "C"
+
+ case 0::Integer of
+ 0 -> putStrLn "A"
+ 1 -> putStrLn "B"
+ 2 -> putStrLn "C"
+
+ case 0::Integer of
+ 1 -> putStrLn "B"
+ 2 -> putStrLn "C"
+
+ case 3::Integer of
+ 1 -> putStrLn "B"
+ 2 -> putStrLn "C"
diff --git a/testsuite/tests/deSugar/should_compile/T14546a.stderr b/testsuite/tests/deSugar/should_compile/T14546a.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..5918a45cc7f15474ab1403571013ca79c5aef2ec
--- /dev/null
+++ b/testsuite/tests/deSugar/should_compile/T14546a.stderr
@@ -0,0 +1,56 @@
+
+T14546a.hs:5:7: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In a case alternative: 1 -> ...
+
+T14546a.hs:6:7: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In a case alternative: _ -> ...
+
+T14546a.hs:10:7: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In a case alternative: 1 -> ...
+
+T14546a.hs:11:7: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In a case alternative: 2 -> ...
+
+T14546a.hs:15:7: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In a case alternative: 1 -> ...
+
+T14546a.hs:16:7: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In a case alternative: _ -> ...
+
+T14546a.hs:20:7: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In a case alternative: 1 -> ...
+
+T14546a.hs:21:7: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In a case alternative: 2 -> ...
+
+T14546a.hs:23:4: warning: [-Wincomplete-patterns (in -Wextra)]
+ Pattern match(es) are non-exhaustive
+ In a case alternative: Patterns not matched: 0
+
+T14546a.hs:24:7: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In a case alternative: 1 -> ...
+
+T14546a.hs:25:7: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In a case alternative: 2 -> ...
+
+T14546a.hs:27:4: warning: [-Wincomplete-patterns (in -Wextra)]
+ Pattern match(es) are non-exhaustive
+ In a case alternative: Patterns not matched: 3
+
+T14546a.hs:28:7: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In a case alternative: 1 -> ...
+
+T14546a.hs:29:7: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In a case alternative: 2 -> ...
diff --git a/testsuite/tests/deSugar/should_compile/T14546b.hs b/testsuite/tests/deSugar/should_compile/T14546b.hs
new file mode 100644
index 0000000000000000000000000000000000000000..7dd0b233848639513032bf5c5c827e5155267138
--- /dev/null
+++ b/testsuite/tests/deSugar/should_compile/T14546b.hs
@@ -0,0 +1,11 @@
+main :: IO ()
+main = do
+ case "foo" of
+ ('f':_) -> putStrLn "A"
+ ('f':'o':_) -> putStrLn "B"
+ "bar" -> putStrLn "C"
+
+ case "foo" of
+ "foo" -> putStrLn "A"
+ "bar" -> putStrLn "B"
+ "baz" -> putStrLn "C"
diff --git a/testsuite/tests/deSugar/should_compile/T14546b.stderr b/testsuite/tests/deSugar/should_compile/T14546b.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..00b4286a48975b47f0a36431c72c910cd01c32e2
--- /dev/null
+++ b/testsuite/tests/deSugar/should_compile/T14546b.stderr
@@ -0,0 +1,16 @@
+
+T14546b.hs:5:7: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In a case alternative: ('f' : 'o' : _) -> ...
+
+T14546b.hs:6:7: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In a case alternative: "bar" -> ...
+
+T14546b.hs:10:7: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In a case alternative: "bar" -> ...
+
+T14546b.hs:11:7: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In a case alternative: "baz" -> ...
diff --git a/testsuite/tests/deSugar/should_compile/T14546c.hs b/testsuite/tests/deSugar/should_compile/T14546c.hs
new file mode 100644
index 0000000000000000000000000000000000000000..886511b65a87060ca17f00dd4373c249e413004a
--- /dev/null
+++ b/testsuite/tests/deSugar/should_compile/T14546c.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+import qualified Data.ByteString as B
+
+main :: IO ()
+main = do
+ case "foo" of
+ ('f':_) -> putStrLn "A"
+ ('f':'o':_) -> putStrLn "B"
+ "bar" -> putStrLn "C"
+
+ case "foo" of
+ "foo" -> putStrLn "A"
+ "bar" -> putStrLn "B"
+ "baz" -> putStrLn "C"
+
+ case ("foo" :: B.ByteString) of
+ "foo" -> putStrLn "A"
+ "bar" -> putStrLn "B"
+ "baz" -> putStrLn "C"
diff --git a/testsuite/tests/deSugar/should_compile/T14546c.stderr b/testsuite/tests/deSugar/should_compile/T14546c.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..0ea6ca00121337bf917da6bf1fb9eea91405053e
--- /dev/null
+++ b/testsuite/tests/deSugar/should_compile/T14546c.stderr
@@ -0,0 +1,24 @@
+
+T14546c.hs:9:7: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In a case alternative: ('f' : 'o' : _) -> ...
+
+T14546c.hs:10:7: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In a case alternative: "bar" -> ...
+
+T14546c.hs:14:7: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In a case alternative: "bar" -> ...
+
+T14546c.hs:15:7: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In a case alternative: "baz" -> ...
+
+T14546c.hs:19:7: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In a case alternative: "bar" -> ...
+
+T14546c.hs:20:7: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In a case alternative: "baz" -> ...
diff --git a/testsuite/tests/deSugar/should_compile/all.T b/testsuite/tests/deSugar/should_compile/all.T
index 14140737d8c0a03a01949dc7d9a9bb240fa89296..9951047e99cbd384fa829d0a5e7023d6cb50295b 100644
--- a/testsuite/tests/deSugar/should_compile/all.T
+++ b/testsuite/tests/deSugar/should_compile/all.T
@@ -100,6 +100,9 @@ test('T13290', normal, compile, [''])
test('T13257', normal, compile, [''])
test('T13870', normal, compile, [''])
test('T14135', normal, compile, [''])
+test('T14546a', normal, compile, ['-Wincomplete-patterns'])
+test('T14546b', normal, compile, ['-Wincomplete-patterns'])
+test('T14546c', normal, compile, ['-Wincomplete-patterns'])
test('T14547', normal, compile, ['-Wincomplete-patterns'])
test('T14773a', normal, compile, ['-Wincomplete-patterns'])
test('T14773b', normal, compile, ['-Wincomplete-patterns'])
diff --git a/testsuite/tests/simplCore/should_compile/T9400.stderr b/testsuite/tests/simplCore/should_compile/T9400.stderr
index 6ca59ca7c71421e9cbcfe0b6483f337b04f8009e..521b862d57ce524aa833ea698bb4264abbc783ab 100644
--- a/testsuite/tests/simplCore/should_compile/T9400.stderr
+++ b/testsuite/tests/simplCore/should_compile/T9400.stderr
@@ -1,4 +1,12 @@
+T9400.hs:13:9: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In a case alternative: [] -> ...
+
+T9400.hs:18:9: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In a case alternative: "" -> ...
+
==================== Tidy Core ====================
Result size of Tidy Core
= {terms: 37, types: 22, coercions: 0, joins: 0/0}