Fail eagerly on a lev-poly datacon arg

Close #18534.

See commentary in the patch.

4 files changed, 39 insertions, 11 deletions

diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index c928a529fd..0b8ec842b2 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -74,7 +74,6 @@ import GHC.Types.SrcLoc
 import GHC.Data.List.SetOps
 import GHC.Driver.Session
 import GHC.Types.Unique
-import GHC.Core.ConLike( ConLike(..) )
 import GHC.Types.Basic
 import qualified GHC.LanguageExtensions as LangExt
 
@@ -3819,15 +3818,14 @@ checkValidTyCl tc
   where
     recovery_code -- See Note [Recover from validity error]
       = do { traceTc "Aborted validity for tycon" (ppr tc)
-           ; return (concatMap mk_fake_tc $
-                     ATyCon tc : implicitTyConThings tc) }
+           ; return (map mk_fake_tc $
+                     tc : child_tycons tc) }
 
-    mk_fake_tc (ATyCon tc)
-      | isClassTyCon tc = [tc]   -- Ugh! Note [Recover from validity error]
-      | otherwise       = [makeRecoveryTyCon tc]
-    mk_fake_tc (AConLike (RealDataCon dc))
-                        = [makeRecoveryTyCon (promoteDataCon dc)]
-    mk_fake_tc _        = []
+    mk_fake_tc tc
+      | isClassTyCon tc = tc   -- Ugh! Note [Recover from validity error]
+      | otherwise       = makeRecoveryTyCon tc
+
+    child_tycons tc = tyConATs tc ++ map promoteDataCon (tyConDataCons tc)
 
 {- Note [Recover from validity error]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -3852,6 +3850,8 @@ Some notes:
   and so there was an internal error when we met 'MkT' in the body of
   'S'.
 
+  Similarly for associated types.
+
 * Painfully, we *don't* want to do this for classes.
   Consider tcfail041:
      class (?x::Int) => C a where ...
@@ -3864,6 +3864,14 @@ Some notes:
   This is really bogus; now we have in scope a Class that is invalid
   in some way, with unknown downstream consequences.  A better
   alternative might be to make a fake class TyCon.  A job for another day.
+
+* Previously, we used implicitTyConThings to snaffle out the parts
+  to add to the context. The problem is that this also grabs data con
+  wrapper Ids. These could be filtered out. But, painfully, getting
+  the wrapper Ids checks the DataConRep, and forcing the DataConRep
+  can panic if there is a levity-polymorphic argument. This is #18534.
+  We don't need the wrapper Ids here anyway. So the code just takes what
+  it needs, via child_tycons.
 -}
 
 -------------------------
@@ -4050,8 +4058,13 @@ checkValidDataCon dflags existential_ok tc con
           -- regardless of whether or not UnliftedNewtypes is enabled. A
           -- later check in checkNewDataCon handles this, producing a
           -- better error message than checkForLevPoly would.
-        ; unless (isNewTyCon tc)
-            (mapM_ (checkForLevPoly empty) (map scaledThing $ dataConOrigArgTys con))
+        ; unless (isNewTyCon tc) $
+            checkNoErrs $
+            mapM_ (checkForLevPoly empty) (map scaledThing $ dataConOrigArgTys con)
+            -- the checkNoErrs is to prevent a panic in isVanillaDataCon
+            -- (called a a few lines down), which can fall over if there is a
+            -- bang on a levity-polymorphic argument. This is #18534,
+            -- typecheck/should_fail/T18534
 
           -- Extra checks for newtype data constructors. Importantly, these
           -- checks /must/ come before the call to checkValidType below. This
diff --git a/testsuite/tests/typecheck/should_fail/T18534.hs b/testsuite/tests/typecheck/should_fail/T18534.hs
new file mode 100644
index 0000000000..7877ff47ee
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T18534.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE PolyKinds #-}
+
+module Test where
+
+import GHC.Exts
+
+data Test (a :: TYPE r) = Test !a
diff --git a/testsuite/tests/typecheck/should_fail/T18534.stderr b/testsuite/tests/typecheck/should_fail/T18534.stderr
new file mode 100644
index 0000000000..cd78fbf819
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T18534.stderr
@@ -0,0 +1,7 @@
+
+T18534.hs:7:27: error:
+    • A levity-polymorphic type is not allowed here:
+        Type: a
+        Kind: TYPE r
+    • In the definition of data constructor ‘Test’
+      In the data type declaration for ‘Test’
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index 7b4d6d1899..49a3cb8cec 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -578,3 +578,4 @@ test('T18357', normal, compile_fail, [''])
 test('T18357a', normal, compile_fail, [''])
 test('T18357b', normal, compile_fail, [''])
 test('T18455', normal, compile_fail, [''])
+test('T18534', normal, compile_fail, [''])