Don't skip validity checks for built-in classes (#17355)

Issue #17355 occurred because the control flow for
`TcValidity.check_valid_inst_head` was structured in such a way that
whenever it checked a special, built-in class (like `Generic` or
`HasField`), it would skip the most important check of all:
`checkValidTypePats`, which rejects nonsense like this:

```hs
instance Generic (forall a. a)
```

This fixes the issue by carving out `checkValidTypePats` from
`check_valid_inst_head` so that `checkValidTypePats` is always
invoked. `check_valid_inst_head` has also been renamed to
`check_special_inst_head` to reflect its new purpose of _only_
checking for instances headed by special classes.

Fixes #17355.

(cherry picked from commit f375e3fb060653beb12b05b48ac0fd3f88eb2f45)

5 files changed, 27 insertions, 6 deletions

diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs
index 218f539c68..7ce71c5dbc 100644
--- a/compiler/typecheck/TcValidity.hs
+++ b/compiler/typecheck/TcValidity.hs
@@ -1360,7 +1360,8 @@ checkValidInstHead ctxt clas cls_args
   = do { dflags   <- getDynFlags
        ; is_boot  <- tcIsHsBootOrSig
        ; is_sig   <- tcIsHsig
-       ; check_valid_inst_head dflags is_boot is_sig ctxt clas cls_args
+       ; check_special_inst_head dflags is_boot is_sig ctxt clas cls_args
+       ; checkValidTypePats (classTyCon clas) cls_args
        }
 
 {-
@@ -1388,10 +1389,10 @@ in hsig files, where `is_sig` is True.
 
 -}
 
-check_valid_inst_head :: DynFlags -> Bool -> Bool
-                      -> UserTypeCtxt -> Class -> [Type] -> TcM ()
+check_special_inst_head :: DynFlags -> Bool -> Bool
+                        -> UserTypeCtxt -> Class -> [Type] -> TcM ()
 -- Wow!  There are a surprising number of ad-hoc special cases here.
-check_valid_inst_head dflags is_boot is_sig ctxt clas cls_args
+check_special_inst_head dflags is_boot is_sig ctxt clas cls_args
 
   -- If not in an hs-boot file, abstract classes cannot have instances
   | isAbstractClass clas
@@ -1441,7 +1442,7 @@ check_valid_inst_head dflags is_boot is_sig ctxt clas cls_args
   = failWithTc (instTypeErr clas cls_args msg)
 
   | otherwise
-  = checkValidTypePats (classTyCon clas) cls_args
+  = pure ()
   where
     clas_nm = getName clas
     ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args
diff --git a/libraries/stm b/libraries/stm
-Subproject a925aaa505d9259f26e2f3fb2ffa2e9b66b4874
+Subproject f9979c926ca539362b5a2412359750e8b498e53
diff --git a/testsuite/tests/typecheck/should_fail/T17355.hs b/testsuite/tests/typecheck/should_fail/T17355.hs
new file mode 100644
index 0000000000..cf9fb651cc
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T17355.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE RankNTypes, DataKinds #-}
+module T17355 where
+
+import GHC.Generics
+import GHC.Records
+
+data Foo = Foo { poly :: forall a. a -> a }
+
+instance Generic (forall a . a)
+instance HasField "myPoly" Foo (forall a. a -> a) where
+    getField (Foo x) = x
diff --git a/testsuite/tests/typecheck/should_fail/T17355.stderr b/testsuite/tests/typecheck/should_fail/T17355.stderr
new file mode 100644
index 0000000000..5212ef8787
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T17355.stderr
@@ -0,0 +1,9 @@
+
+T17355.hs:9:10: error:
+    • Illegal polymorphic type: forall a. a
+    • In the instance declaration for ‘Generic (forall a. a)’
+
+T17355.hs:10:10: error:
+    • Illegal polymorphic type: forall a. a -> a
+    • In the instance declaration for
+        ‘HasField "myPoly" Foo (forall a. a -> a)’
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index b921a00e02..3053929dac 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -1,4 +1,3 @@
-4607
 test('tcfail001', normal, compile_fail, [''])
 test('tcfail002', normal, compile_fail, [''])
 test('tcfail003', normal, compile_fail, [''])
@@ -513,3 +512,4 @@ test('T16059e', [extra_files(['T16059b.hs'])], multimod_compile_fail,
 test('T16255', normal, compile_fail, [''])
 test('T16204c', normal, compile_fail, [''])
 test('T16517', normal, compile_fail, [''])
+test('T17355', normal, compile_fail, [''])