Add a bunch of testcases for the pattern match checker

Adds regression tests for tickets #17207, #17208, #17215, #17216,
 #17218, #17219, #17248

13 files changed, 230 insertions, 0 deletions

diff --git a/testsuite/tests/pmcheck/should_compile/T14899.hs b/testsuite/tests/pmcheck/should_compile/T14899.hs
new file mode 100644
index 0000000000..a788f29ee8
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T14899.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeInType #-}
+module Bug where
+
+data family Sing (z :: k)
+
+class SEq k where
+  (%==) :: forall (a :: k) (b :: k). Sing a -> Sing b -> ()
+  infix 4 %==
+
+data Foo a b c d
+  = A a b c d |
+    B a b c d |
+    C a b c d |
+    D a b c d |
+    E a b c d |
+    F a b c d
+
+data instance Sing (z_awDE :: Foo a b c d) where
+    SA :: Sing a -> Sing b -> Sing c -> Sing d -> Sing ('A a b c d)
+    SB :: Sing a -> Sing b -> Sing c -> Sing d -> Sing ('B a b c d)
+    SC :: Sing a -> Sing b -> Sing c -> Sing d -> Sing ('C a b c d)
+    SD :: Sing a -> Sing b -> Sing c -> Sing d -> Sing ('D a b c d)
+    SE :: Sing a -> Sing b -> Sing c -> Sing d -> Sing ('E a b c d)
+    SF :: Sing a -> Sing b -> Sing c -> Sing d -> Sing ('F a b c d)
+
+instance (SEq a, SEq b, SEq c, SEq d) => SEq (Foo a b c d) where
+        (%==) (SA _ _ _ _) (SA _ _ _ _) = ()
+        (%==) (SA _ _ _ _) (SB _ _ _ _) = ()
+        (%==) (SA _ _ _ _) (SC _ _ _ _) = ()
+        (%==) (SA _ _ _ _) (SD _ _ _ _) = ()
+        (%==) (SA _ _ _ _) (SE _ _ _ _) = ()
+        (%==) (SA _ _ _ _) (SF _ _ _ _) = ()
+        (%==) (SB _ _ _ _) (SA _ _ _ _) = ()
+        (%==) (SB _ _ _ _) (SB _ _ _ _) = ()
+        (%==) (SB _ _ _ _) (SC _ _ _ _) = ()
+        (%==) (SB _ _ _ _) (SD _ _ _ _) = ()
+        (%==) (SB _ _ _ _) (SE _ _ _ _) = ()
+        (%==) (SB _ _ _ _) (SF _ _ _ _) = ()
+        (%==) (SC _ _ _ _) (SA _ _ _ _) = ()
+        (%==) (SC _ _ _ _) (SB _ _ _ _) = ()
+        (%==) (SC _ _ _ _) (SC _ _ _ _) = ()
+        (%==) (SC _ _ _ _) (SD _ _ _ _) = ()
+        (%==) (SC _ _ _ _) (SE _ _ _ _) = ()
+        (%==) (SC _ _ _ _) (SF _ _ _ _) = ()
+        (%==) (SD _ _ _ _) (SA _ _ _ _) = ()
+        (%==) (SD _ _ _ _) (SB _ _ _ _) = ()
+        (%==) (SD _ _ _ _) (SC _ _ _ _) = ()
+        (%==) (SD _ _ _ _) (SD _ _ _ _) = ()
+        (%==) (SD _ _ _ _) (SE _ _ _ _) = ()
+        (%==) (SD _ _ _ _) (SF _ _ _ _) = ()
+        (%==) (SE _ _ _ _) (SA _ _ _ _) = ()
+        (%==) (SE _ _ _ _) (SB _ _ _ _) = ()
+        (%==) (SE _ _ _ _) (SC _ _ _ _) = ()
+        (%==) (SE _ _ _ _) (SD _ _ _ _) = ()
+        (%==) (SE _ _ _ _) (SE _ _ _ _) = ()
+        (%==) (SE _ _ _ _) (SF _ _ _ _) = ()
+        (%==) (SF _ _ _ _) (SA _ _ _ _) = ()
+        (%==) (SF _ _ _ _) (SB _ _ _ _) = ()
+        (%==) (SF _ _ _ _) (SC _ _ _ _) = ()
+        (%==) (SF _ _ _ _) (SD _ _ _ _) = ()
+        (%==) (SF _ _ _ _) (SE _ _ _ _) = ()
+        (%==) (SF _ _ _ _) (SF _ _ _ _) = ()
+
diff --git a/testsuite/tests/pmcheck/should_compile/T17207.hs b/testsuite/tests/pmcheck/should_compile/T17207.hs
new file mode 100644
index 0000000000..7dffa2d39a
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T17207.hs
@@ -0,0 +1,22 @@
+{-# OPTIONS_GHC -Wincomplete-patterns -Wno-missing-methods -fforce-recomp #-}
+{-# LANGUAGE GADTs, TypeFamilies, PatternSynonyms #-}
+module Lib where
+
+data family T a
+
+data instance T () where
+  A :: T ()
+  B :: T ()
+
+pattern C :: T ()
+pattern C = B
+{-# COMPLETE A, C #-}
+
+g :: T () -> ()
+g A = ()
+g C = ()
+
+h :: T () -> ()
+h C = ()
+h A = ()
+
diff --git a/testsuite/tests/pmcheck/should_compile/T17208.hs b/testsuite/tests/pmcheck/should_compile/T17208.hs
new file mode 100644
index 0000000000..e7b4efd2de
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T17208.hs
@@ -0,0 +1,14 @@
+{-# OPTIONS_GHC -Wincomplete-patterns -fforce-recomp #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Lib where
+
+safeLast :: [a] -> Maybe a
+safeLast xs
+  | []    <- reverse xs = Nothing
+  | (x:_) <- reverse xs = Just x
+
+safeLast2 :: [a] -> Maybe a
+safeLast2 (reverse -> [])    = Nothing
+safeLast2 (reverse -> (x:_)) = Just x
+
diff --git a/testsuite/tests/pmcheck/should_compile/T17215.hs b/testsuite/tests/pmcheck/should_compile/T17215.hs
new file mode 100644
index 0000000000..6c7976e0d4
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T17215.hs
@@ -0,0 +1,41 @@
+module Lib where
+
+foo :: Bool -> String
+foo True = "True"
+foo i = case i of
+  False -> "False"
+
+bar :: Bool -> String
+bar True = "True"
+bar i = bir i
+  where
+    bir False = "False"
+
+baz :: Bool -> String
+baz i = case i of
+  True -> "True"
+  _ -> case i of
+    False -> "False"
+
+-- Amazingly this does not trigger a warning
+baz' :: Bool -> String
+baz' i = case i of
+  True -> "True"
+  False -> case i of
+    False -> "False"
+
+
+bur :: Bool -> String
+bur True = "True"
+bur i = case i of
+  True -> "True"
+  _ -> boz i
+    where
+      boz False = "False"
+
+
+-- This should not fail
+-- That's a proof that all function are total
+test :: [String]
+test = [foo, bar, baz, baz', bur] <*> [minBound..maxBound]
+
diff --git a/testsuite/tests/pmcheck/should_compile/T17215.stderr b/testsuite/tests/pmcheck/should_compile/T17215.stderr
new file mode 100644
index 0000000000..03e8725c8b
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T17215.stderr
@@ -0,0 +1,8 @@
+
+T17215.hs:12:5: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In an equation for ‘bir’: Patterns not matched: True
+
+T17215.hs:34:7: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In an equation for ‘boz’: Patterns not matched: True
diff --git a/testsuite/tests/pmcheck/should_compile/T17216.hs b/testsuite/tests/pmcheck/should_compile/T17216.hs
new file mode 100644
index 0000000000..64a778391e
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T17216.hs
@@ -0,0 +1,8 @@
+module Lib where
+
+foo :: Int -> Bool
+foo i
+  | i < 0 = True
+  | i == 0 = True
+  | i > 0 = True
+
diff --git a/testsuite/tests/pmcheck/should_compile/T17218.hs b/testsuite/tests/pmcheck/should_compile/T17218.hs
new file mode 100644
index 0000000000..add85696ff
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T17218.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module Lib where
+
+data T = A | B | C
+
+pattern P = B
+{-# COMPLETE A, P #-}
+
+f :: T -> ()
+f A = ()
diff --git a/testsuite/tests/pmcheck/should_compile/T17218.stderr b/testsuite/tests/pmcheck/should_compile/T17218.stderr
new file mode 100644
index 0000000000..1eaaa1f474
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T17218.stderr
@@ -0,0 +1,6 @@
+
+T17218.hs:11:1: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In an equation for ‘f’:
+        Patterns not matched:
+            C
diff --git a/testsuite/tests/pmcheck/should_compile/T17219.hs b/testsuite/tests/pmcheck/should_compile/T17219.hs
new file mode 100644
index 0000000000..66f470295e
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T17219.hs
@@ -0,0 +1,10 @@
+{-# OPTIONS_GHC -Wincomplete-patterns #-}
+{-# LANGUAGE OverloadedLists #-}
+
+module Weird where
+
+import Data.Sequence
+
+f :: Seq Int -> ()
+f [0] = ()
+
diff --git a/testsuite/tests/pmcheck/should_compile/T17219.stderr b/testsuite/tests/pmcheck/should_compile/T17219.stderr
new file mode 100644
index 0000000000..3ec5471429
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T17219.stderr
@@ -0,0 +1,8 @@
+
+T17219.hs:9:1: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In an equation for ‘f’:
+        Patterns not matched:
+            (0:_:_)
+            (p:_) where p is not one of {0}
+            []
diff --git a/testsuite/tests/pmcheck/should_compile/T17248.hs b/testsuite/tests/pmcheck/should_compile/T17248.hs
new file mode 100644
index 0000000000..e320bd5184
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T17248.hs
@@ -0,0 +1,15 @@
+module Lib where
+
+data T1 a = T1 a
+newtype T2 a = T2 a
+
+f :: T1 a -> Bool -> ()
+f _      True = ()
+f (T1 _) True = ()
+f _      _    = ()
+
+g :: T2 a -> Bool -> ()
+g _      True = ()
+g (T2 _) True = ()
+g _      _    = ()
+
diff --git a/testsuite/tests/pmcheck/should_compile/T17248.stderr b/testsuite/tests/pmcheck/should_compile/T17248.stderr
new file mode 100644
index 0000000000..991f167afb
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T17248.stderr
@@ -0,0 +1,4 @@
+
+T17248.hs:8:1: warning: [-Woverlapping-patterns (in -Wdefault)]
+    Pattern match has inaccessible right hand side
+    In an equation for ‘f’: f (T1 _) True = ...
diff --git a/testsuite/tests/pmcheck/should_compile/all.T b/testsuite/tests/pmcheck/should_compile/all.T
index 19ae2c71b9..65f8710a7f 100644
--- a/testsuite/tests/pmcheck/should_compile/all.T
+++ b/testsuite/tests/pmcheck/should_compile/all.T
@@ -56,6 +56,8 @@ test('T14098', normal, compile,
      ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
 test('T14813', normal, compile,
      ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
+test('T14899', normal, compile,
+     ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
 test('T15305', normal, compile,
      ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
 test('T15385', normal, compile,
@@ -82,8 +84,22 @@ test('T17096', collect_compiler_stats('bytes allocated',10), compile,
      ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns +RTS -M2G -RTS'])
 test('T17112', normal, compile,
      ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
+test('T17207', expect_broken(17207), compile,
+     ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
+test('T17208', expect_broken(17208), compile,
+     ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
+test('T17215', expect_broken(17215), compile,
+     ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
+test('T17216', expect_broken(17216), compile,
+     ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
+test('T17218', expect_broken(17218), compile,
+     ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
+test('T17219', expect_broken(17219), compile,
+     ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
 test('T17234', normal, compile,
      ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
+test('T17248', expect_broken(17248), compile,
+     ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
 
 # Other tests
 test('pmc001', [], compile,