Bring back COMPLETE sets filtered by result TyCon (#14422)

Commit 2a94228 dramatically simplified the implementation and improved
the performance of COMPLETE sets while making them applicable in more
scenarios at the same time.
But it turned out that there was a change in semantics that (to me
unexpectedly) broke users' expectations (see #14422): They relied on the
"type signature" of a COMPLETE pragma to restrict the scrutinee types of
a pattern match for which they are applicable.

This patch brings back that filtering, so the semantics is the same as
it was in GHC 9.0.
See the updated Note [Implementation of COMPLETE pragmas].

There are a few testsuite output changes (`completesig13`, `T14422`)
which assert this change.

Co-authored-by: Sebastian Graf <sebastian.graf@kit.edu>

4 files changed, 46 insertions, 8 deletions

diff --git a/testsuite/tests/pmcheck/complete_sigs/T14422.hs b/testsuite/tests/pmcheck/complete_sigs/T14422.hs
index be879f4b13..8e371fd5e0 100644
--- a/testsuite/tests/pmcheck/complete_sigs/T14422.hs
+++ b/testsuite/tests/pmcheck/complete_sigs/T14422.hs
@@ -1,7 +1,7 @@
 {-# OPTIONS_GHC -Wall #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ViewPatterns #-}
-module Completesig15 where
+module T14422 where
 
 class C f where
   foo :: f a -> ()
@@ -13,3 +13,33 @@ pattern P <- (foo -> ())
 
 f :: C f => f a -> ()
 f P = () -- A complete match
+
+-- But we also have to be able to constrain applicability of a COMPLETE sig.
+-- Hence another example:
+
+class D f where
+  bar :: f a -> ()
+
+pattern Q :: D f => f a
+pattern Q <- (bar -> ())
+
+instance D [] where
+  bar _ = ()
+{-# COMPLETE Q :: [] #-}
+
+g :: D f => f a -> ()
+g Q = () -- Should warn! The sig shouldn't apply in a polymorphic context.
+
+h :: [a] -> ()
+h Q = () -- A complete match
+
+-- What currently isn't possible (although, yet):
+class D f => E f where
+  -- Law: every match on 'Q' is COMPLETE
+
+-- Commented out, because it's invalid syntax ATM.
+-- {-# COMPLETE Q :: E f => f a #-}
+
+i :: E f => f a -> ()
+i Q = () -- Would be a complete match with GHC proposal #400
+
diff --git a/testsuite/tests/pmcheck/complete_sigs/T14422.stderr b/testsuite/tests/pmcheck/complete_sigs/T14422.stderr
new file mode 100644
index 0000000000..26a03573ae
--- /dev/null
+++ b/testsuite/tests/pmcheck/complete_sigs/T14422.stderr
@@ -0,0 +1,8 @@
+
+T14422.hs:31:1: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In an equation for ‘g’: Patterns of type ‘f a’ not matched: P
+
+T14422.hs:44:1: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In an equation for ‘i’: Patterns of type ‘f a’ not matched: P
diff --git a/testsuite/tests/pmcheck/complete_sigs/T18960b.stderr b/testsuite/tests/pmcheck/complete_sigs/T18960b.stderr
index 6af7fa7bc1..fd27f0853e 100644
--- a/testsuite/tests/pmcheck/complete_sigs/T18960b.stderr
+++ b/testsuite/tests/pmcheck/complete_sigs/T18960b.stderr
@@ -3,18 +3,18 @@ T18960b.hs:11:7: warning: [-Wincomplete-patterns (in -Wextra)]
     Pattern match(es) are non-exhaustive
     In a case alternative:
         Patterns of type ‘((), String)’ not matched:
+            (_, _)
             P ((), [])
-            P ((), (p : P _)) where p is not one of {'h'}
-            P ((), ['h'])
-            P ((), ('h' : p : P _)) where p is not one of {'e'}
+            P ((), [p]) where p is not one of {'h'}
+            P ((), (p:_:_)) where p is not one of {'h'}
             ...
 
 T18960b.hs:18:7: warning: [-Wincomplete-patterns (in -Wextra)]
     Pattern match(es) are non-exhaustive
     In a case alternative:
         Patterns of type ‘((), String)’ not matched:
+            (_, _)
             P ((), [])
-            P ((), (p : P _)) where p is not one of {'h'}
-            P ((), ['h'])
-            P ((), ('h' : p : P _)) where p is not one of {'e'}
+            P ((), [p]) where p is not one of {'h'}
+            P ((), (p:_:_)) where p is not one of {'h'}
             ...
diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig13.hs b/testsuite/tests/pmcheck/complete_sigs/completesig13.hs
index ac87baf9f0..e545ef8d9b 100644
--- a/testsuite/tests/pmcheck/complete_sigs/completesig13.hs
+++ b/testsuite/tests/pmcheck/complete_sigs/completesig13.hs
@@ -2,7 +2,7 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# OPTIONS_GHC -Wall #-}
-module Completesig11 where
+module Completesig13 where
 
 class LL f where
   go :: f a -> ()