diff options
author | sheaf <sam.derbyshire@gmail.com> | 2023-05-11 13:08:14 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2023-05-12 06:10:57 -0400 |
commit | c176ad1835ccfe55e2bde875b4a35e9d226ff657 (patch) | |
tree | 585897cd4bdbb5babd5c86eaed88aa26a8a42595 /compiler/GHC | |
parent | a856d98eb13401b78fa7eba9a54ea4c501ebb0a2 (diff) | |
download | haskell-c176ad1835ccfe55e2bde875b4a35e9d226ff657.tar.gz |
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
Diffstat (limited to 'compiler/GHC')
-rw-r--r-- | compiler/GHC/Core/Type.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Tc/TyCl.hs | 47 | ||||
-rw-r--r-- | compiler/GHC/Tc/TyCl/Build.hs | 20 |
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 |