testsuite: Add test for #21719

Happily, this has been fixed since 9.2.

3 files changed, 67 insertions, 0 deletions

diff --git a/testsuite/tests/partial-sigs/should_compile/T21719.hs b/testsuite/tests/partial-sigs/should_compile/T21719.hs
new file mode 100644
index 0000000000..738b01746c
--- /dev/null
+++ b/testsuite/tests/partial-sigs/should_compile/T21719.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE BlockArguments #-}
+
+module T21719 where
+
+import Control.Exception
+
+data Foo = Foo
+  deriving (Show, Exception)
+
+class CanThrow e
+
+qux :: Monad m => (CanThrow Foo => m a) -> m a
+qux _ = undefined
+
+class Monad m => MonadCheckedThrow m where
+    throwChecked :: (Exception e, CanThrow e) => e -> m a
+
+foo :: MonadCheckedThrow m => m Int
+foo = do
+  qux do
+    _ <- baz
+    pure 5
+  where
+    baz :: (CanThrow Foo, _) => _
+    baz = throwChecked Foo
+
diff --git a/testsuite/tests/partial-sigs/should_compile/T21719.stderr b/testsuite/tests/partial-sigs/should_compile/T21719.stderr
new file mode 100644
index 0000000000..944729e88a
--- /dev/null
+++ b/testsuite/tests/partial-sigs/should_compile/T21719.stderr
@@ -0,0 +1,35 @@
+
+T21719.hs:29:27: warning: [-Wpartial-type-signatures (in -Wdefault)]
+    • Found extra-constraints wildcard standing for
+        ‘MonadCheckedThrow m1’
+      Where: ‘m1’ is a rigid type variable bound by
+               the inferred type of
+                 baz :: (CanThrow Foo, MonadCheckedThrow m1) => m1 a
+               at T21719.hs:30:5-26
+    • In the type signature: baz :: (CanThrow Foo, _) => _
+      In an equation for ‘foo’:
+          foo
+            = do qux
+                   do _ <- baz
+                      ....
+            where
+                baz :: (CanThrow Foo, _) => _
+                baz = throwChecked Foo
+    • Relevant bindings include foo :: m Int (bound at T21719.hs:24:1)
+
+T21719.hs:29:33: warning: [-Wpartial-type-signatures (in -Wdefault)]
+    • Found type wildcard ‘_’ standing for ‘m1 a’
+      Where: ‘m1’, ‘a’ are rigid type variables bound by
+               the inferred type of
+                 baz :: (CanThrow Foo, MonadCheckedThrow m1) => m1 a
+               at T21719.hs:30:5-26
+    • In the type signature: baz :: (CanThrow Foo, _) => _
+      In an equation for ‘foo’:
+          foo
+            = do qux
+                   do _ <- baz
+                      ....
+            where
+                baz :: (CanThrow Foo, _) => _
+                baz = throwChecked Foo
+    • Relevant bindings include foo :: m Int (bound at T21719.hs:24:1)
diff --git a/testsuite/tests/partial-sigs/should_compile/all.T b/testsuite/tests/partial-sigs/should_compile/all.T
index 1a786bd363..3a7e9355a0 100644
--- a/testsuite/tests/partial-sigs/should_compile/all.T
+++ b/testsuite/tests/partial-sigs/should_compile/all.T
@@ -102,5 +102,6 @@ test('T16762d', normal, compile, [''])
 test('T14658', normal, compile, [''])
 test('T18646', normal, compile, [''])
 test('T20921', normal, compile, [''])
+test('T21719', normal, compile, [''])
 test('InstanceGivenOverlap3', expect_broken(20076), compile, [''])
 test('T21667', normal, compile, [''])