From c176ad1835ccfe55e2bde875b4a35e9d226ff657 Mon Sep 17 00:00:00 2001 From: sheaf Date: Thu, 11 May 2023 13:08:14 +0200 Subject: 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 --- compiler/GHC/Core/Type.hs | 2 +- compiler/GHC/Tc/TyCl.hs | 47 ++++++++++++-------- compiler/GHC/Tc/TyCl/Build.hs | 20 ++++++--- testsuite/tests/typecheck/should_fail/T23308.hs | 39 +++++++++++++++++ .../tests/typecheck/should_fail/T23308.stderr | 50 ++++++++++++++++++++++ testsuite/tests/typecheck/should_fail/all.T | 1 + 6 files changed, 133 insertions(+), 26 deletions(-) create mode 100644 testsuite/tests/typecheck/should_fail/T23308.hs create mode 100644 testsuite/tests/typecheck/should_fail/T23308.stderr 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, ['']) -- cgit v1.2.1