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

3 files changed, 43 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