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

7 files changed, 159 insertions, 0 deletions

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'])