Make `singleConstructor` cope with pattern synonyms

Previously, `singleConstructor` didn't handle singleton `COMPLETE` sets
of a single pattern synonym, resulting in incomplete pattern warnings
in #15753.

This is fixed by making `singleConstructor` (now named
`singleMatchConstructor`) query `allCompleteMatches`, necessarily making
it effectful. As a result, most of this patch is concerned with
threading the side-effect through to `singleMatchConstructor`.

Unfortunately, this is not enough to completely fix the original
reproduction from #15753 and #15884, which are related to function
applications in pattern guards being translated too conservatively.

4 files changed, 51 insertions, 0 deletions

diff --git a/testsuite/tests/pmcheck/should_compile/T15753a.hs b/testsuite/tests/pmcheck/should_compile/T15753a.hs
new file mode 100644
index 0000000000..81030f9049
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T15753a.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -Wincomplete-patterns #-}
+module Bug where
+
+import Data.Type.Equality
+
+data G a where
+  GInt  :: G Int
+  GBool :: G Bool
+
+ex1, ex2, ex3
+  :: a :~: Int
+  -> G a
+  -> ()
+
+ex1 Refl g
+  | GInt <- id g
+  = ()
+
+ex2 Refl g
+  | GInt <- g
+  = ()
+
+ex3 Refl g
+  = case id g of
+      GInt -> ()
+
diff --git a/testsuite/tests/pmcheck/should_compile/T15753b.hs b/testsuite/tests/pmcheck/should_compile/T15753b.hs
new file mode 100644
index 0000000000..cb629c3857
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T15753b.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE PatternSynonyms #-}
+module Bug where
+
+{-# COMPLETE Id #-}
+pattern Id :: ()
+pattern Id = ()
+
+bug :: ()
+bug | Id <- id () = ()
+
diff --git a/testsuite/tests/pmcheck/should_compile/T15884.hs b/testsuite/tests/pmcheck/should_compile/T15884.hs
new file mode 100644
index 0000000000..676aee76d1
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T15884.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE ViewPatterns #-}
+
+module Bug where
+
+f :: Maybe a -> Bool
+f (id->Nothing)  = False
+f (id->(Just _)) = True
diff --git a/testsuite/tests/pmcheck/should_compile/all.T b/testsuite/tests/pmcheck/should_compile/all.T
index a93a65f7f6..e04f2cf07c 100644
--- a/testsuite/tests/pmcheck/should_compile/all.T
+++ b/testsuite/tests/pmcheck/should_compile/all.T
@@ -68,6 +68,12 @@ test('T15584', normal, compile,
      ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
 test('T15713', normal, compile,
      ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
+test('T15753a', expect_broken(15753), compile,
+     ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
+test('T15753b', normal, compile,
+     ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
+test('T15884', expect_broken(15884), compile,
+     ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
 test('T16289', normal, compile,
      ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])