Improve exhaustiveness checking for literal values and patterns, fix #14546

Currently, 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 #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.  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`, whether it's type is `String` or not. 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 #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"
```

Test Plan: make test TEST="T14546"

Reviewers: bgamari, simonpj

Reviewed By: bgamari, simonpj

Subscribers: simonpj, thomie, carter

GHC Trac Issues: #14546

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

12 files changed, 308 insertions, 72 deletions

diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index a776abe076..ba6415402a 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 fabbe2bc2f..ec831acdb1 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 c7bff64ff3..d715439015 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 56d310f618..fbacb989a1 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 0000000000..085ea3ced9
--- /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 0000000000..5918a45cc7
--- /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 0000000000..7dd0b23384
--- /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 0000000000..00b4286a48
--- /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 0000000000..886511b65a
--- /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 0000000000..0ea6ca0012
--- /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 14140737d8..9951047e99 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 6ca59ca7c7..521b862d57 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}