Don't panic in mkNewTyConRhs

This function could come across invalid newtype constructors, as we
only perform validity checking of newtypes once we are outside the
knot-tied typechecking loop.
This patch changes this function to fake up a stub type in the case of
an invalid newtype, instead of panicking.

This patch also changes "checkNewDataCon" so that it reports as many
errors as possible at once.

Fixes #23308

6 files changed, 133 insertions, 26 deletions

diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs
index 86f483abca..796fb5aecd 100644
--- a/compiler/GHC/Core/Type.hs
+++ b/compiler/GHC/Core/Type.hs
@@ -1505,7 +1505,7 @@ piResultTys ty orig_args@(arg:args)
         -- c.f. #15473
         pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args)
 
-applyTysX :: [TyVar] -> Type -> [Type] -> Type
+applyTysX :: HasDebugCallStack => [TyVar] -> Type -> [Type] -> Type
 -- applyTysX beta-reduces (/\tvs. body_ty) arg_tys
 -- Assumes that (/\tvs. body_ty) is closed
 applyTysX tvs body_ty arg_tys
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index de6ef49225..a2d507475a 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -4516,31 +4516,40 @@ checkNewDataCon :: DataCon -> TcM ()
 -- But they are caught earlier, by GHC.Tc.Gen.HsType.checkDataKindSig
 checkNewDataCon con
   = do  { show_linear_types <- xopt LangExt.LinearTypes <$> getDynFlags
-
-        ; checkTc (isSingleton arg_tys) $
-          TcRnIllegalNewtype con show_linear_types (DoesNotHaveSingleField $ length arg_tys)
-
-        ; checkTc (ok_mult (scaledMult arg_ty1)) $
-          TcRnIllegalNewtype con show_linear_types IsNonLinear
-
-        ; checkTc (null eq_spec) $
-          TcRnIllegalNewtype con show_linear_types IsGADT
-
-        ; checkTc (null theta) $
+        ; checkNoErrs $
+          -- Fail here if the newtype is invalid: subsequent code in
+          -- checkValidDataCon can fall over if it comes across an invalid newtype.
+     do { case arg_tys of
+            [Scaled arg_mult _] ->
+              unless (ok_mult arg_mult) $
+              addErrTc $
+              TcRnIllegalNewtype con show_linear_types IsNonLinear
+            _ ->
+              addErrTc $
+              TcRnIllegalNewtype con show_linear_types (DoesNotHaveSingleField $ length arg_tys)
+
+          -- Add an error if the newtype is a GADt or has existentials.
+          --
+          -- If the newtype is a GADT, the GADT error is enough;
+          -- we don't need to *also* complain about existentials.
+        ; if not (null eq_spec)
+          then addErrTc $ TcRnIllegalNewtype con show_linear_types IsGADT
+          else unless (null ex_tvs) $
+               addErrTc $
+               TcRnIllegalNewtype con show_linear_types HasExistentialTyVar
+
+        ; unless (null theta) $
+          addErrTc $
           TcRnIllegalNewtype con show_linear_types HasConstructorContext
 
-        ; checkTc (null ex_tvs) $
-          TcRnIllegalNewtype con show_linear_types HasExistentialTyVar
-
-        ; checkTc (all ok_bang (dataConSrcBangs con)) $
-          TcRnIllegalNewtype con show_linear_types HasStrictnessAnnotation
-    }
+        ; unless (all ok_bang (dataConSrcBangs con)) $
+          addErrTc $
+          TcRnIllegalNewtype con show_linear_types HasStrictnessAnnotation } }
   where
+
     (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)
       = dataConFullSig con
 
-    (arg_ty1 : _) = arg_tys
-
     ok_bang (HsSrcBang _ _ SrcStrict) = False
     ok_bang (HsSrcBang _ _ SrcLazy)   = False
     ok_bang _                         = True
diff --git a/compiler/GHC/Tc/TyCl/Build.hs b/compiler/GHC/Tc/TyCl/Build.hs
index e7d423f2e1..f02a5467ed 100644
--- a/compiler/GHC/Tc/TyCl/Build.hs
+++ b/compiler/GHC/Tc/TyCl/Build.hs
@@ -18,7 +18,7 @@ module GHC.Tc.TyCl.Build (
 import GHC.Prelude
 
 import GHC.Iface.Env
-import GHC.Builtin.Types( isCTupleTyConName, unboxedUnitTy )
+import GHC.Builtin.Types
 
 import GHC.Tc.Utils.TcType
 import GHC.Tc.Utils.Monad
@@ -65,11 +65,12 @@ mkNewTyConRhs tycon_name tycon con
     tvs      = tyConTyVars tycon
     roles    = tyConRoles tycon
     res_kind = tyConResKind tycon
-    con_arg_ty = case dataConRepArgTys con of
-                   [arg_ty] -> scaledThing arg_ty
-                   tys -> pprPanic "mkNewTyConRhs" (ppr con <+> ppr tys)
-    rhs_ty = substTyWith (dataConUnivTyVars con)
-                         (mkTyVarTys tvs) con_arg_ty
+    rhs_ty
+      -- Only try if the newtype is actually valid (see "otherwise" below).
+      | [Scaled _ arg_ty] <- dataConRepArgTys con
+      , null $ dataConExTyCoVars con
+      = substTyWith (dataConUnivTyVars con)
+                         (mkTyVarTys tvs) arg_ty
         -- Instantiate the newtype's RHS with the
         -- type variables from the tycon
         -- NB: a newtype DataCon has a type that must look like
@@ -78,6 +79,13 @@ mkNewTyConRhs tycon_name tycon con
         -- the newtype arising from   class Foo a => Bar a where {}
         -- has a single argument (Foo a) that is a *type class*, so
         -- dataConInstOrigArgTys returns [].
+      | otherwise
+      -- If the newtype is invalid (e.g. doesn't have a single argument),
+      -- we fake up a type here. The newtype will get rejected once we're
+      -- outside the knot-tied loop, in GHC.Tc.TyCl.checkNewDataCon.
+      -- See the various test cases in T23308.
+      = unitTy -- Might be ill-kinded, but checkNewDataCon should reject this
+               -- whole declaration soon enough, before that causes any problems.
 
     -- Eta-reduce the newtype
     -- See Note [Newtype eta] in GHC.Core.TyCon
diff --git a/testsuite/tests/typecheck/should_fail/T23308.hs b/testsuite/tests/typecheck/should_fail/T23308.hs
new file mode 100644
index 0000000000..c5b55ee2d2
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T23308.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE DataKinds, UnliftedNewtypes, TypeFamilies #-}
+
+module T23308 where
+
+import Data.Proxy
+import GHC.Exts
+
+-- Check that we don't panic in the middle of typechecking
+-- when there is an invalid newtype in a knot-tied group of TyCons.
+
+data A1 = A1 !B1
+newtype B1 = B1 C1 C1
+data C1 = C1 A1
+
+
+data A2 = A2 !B2
+newtype B2 where { B2 :: forall (x :: C2). Proxy x -> B2 }
+data C2 = C2 A2
+
+type F2' :: forall {k}. k -> TYPE WordRep
+type family F2' a where {}
+data A2' = A2' !B2'
+newtype B2' where { B2' :: forall (x :: C2'). F2' x -> B2' }
+data C2' = C2' A2'
+
+
+data A3 = A3 !B3
+newtype B3 where { B3 :: forall (x :: C2). B2 }
+data C3 = C3 A3
+
+
+data A4 = A4 !(B4 Int)
+newtype B4 a where { B4 :: C4 -> B4 Int }
+data C4 = C4 A4
+
+
+data A5 = A5 !(B5 Int)
+newtype B5 a where { B5 :: Num a => B5 (a, a) }
+data C5 = C5 A5
diff --git a/testsuite/tests/typecheck/should_fail/T23308.stderr b/testsuite/tests/typecheck/should_fail/T23308.stderr
new file mode 100644
index 0000000000..299876def4
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T23308.stderr
@@ -0,0 +1,50 @@
+
+T23308.hs:12:14: error: [GHC-23517]
+    • A newtype constructor must have exactly one field
+        but ‘B1’ has two
+      B1 :: C1 -> C1 -> B1
+    • In the definition of data constructor ‘B1’
+      In the newtype declaration for ‘B1’
+
+T23308.hs:17:20: error: [GHC-07525]
+    • A newtype constructor must not have existential type variables
+      B2 :: forall (x :: C2). Proxy x -> B2
+    • In the definition of data constructor ‘B2’
+      In the newtype declaration for ‘B2’
+
+T23308.hs:23:21: error: [GHC-07525]
+    • A newtype constructor must not have existential type variables
+      B2' :: forall (x :: C2'). F2' x -> B2'
+    • In the definition of data constructor ‘B2'’
+      In the newtype declaration for ‘B2'’
+
+T23308.hs:28:20: error: [GHC-45219]
+    • Data constructor ‘B3’ returns type ‘B2’
+        instead of an instance of its parent type ‘B3’
+    • In the definition of data constructor ‘B3’
+      In the newtype declaration for ‘B3’
+
+T23308.hs:33:22: error: [GHC-89498]
+    • A newtype must not be a GADT
+      B4 :: C4 -> B4 Int
+    • In the definition of data constructor ‘B4’
+      In the newtype declaration for ‘B4’
+
+T23308.hs:38:22: error: [GHC-17440]
+    • A newtype constructor must not have a context in its type
+      B5 :: forall a. Num a => B5 (a, a)
+    • In the definition of data constructor ‘B5’
+      In the newtype declaration for ‘B5’
+
+T23308.hs:38:22: error: [GHC-89498]
+    • A newtype must not be a GADT
+      B5 :: forall a. Num a => B5 (a, a)
+    • In the definition of data constructor ‘B5’
+      In the newtype declaration for ‘B5’
+
+T23308.hs:38:22: error: [GHC-23517]
+    • A newtype constructor must have exactly one field
+        but ‘B5’ has none
+      B5 :: forall a. Num a => B5 (a, a)
+    • In the definition of data constructor ‘B5’
+      In the newtype declaration for ‘B5’
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index f62ee5e355..b6c4a0366d 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -676,6 +676,7 @@ test('PatSynExistential', normal, compile_fail, [''])
 test('PatSynArity', normal, compile_fail, [''])
 test('PatSynUnboundVar', normal, compile_fail, [''])
 test('T21444', normal, compile_fail, [''])
+test('T23308', normal, compile_fail, [''])
 test('MultiAssocDefaults', normal, compile_fail, [''])
 test('LazyFieldsDisabled', normal, compile_fail, [''])
 test('TyfamsDisabled', normal, compile_fail, [''])