[Git][ghc/ghc][master] Don't panic in mkNewTyConRhs
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri May 12 10:11:19 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
c176ad18 by sheaf at 2023-05-12T06:10:57-04:00
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 changed files:
- compiler/GHC/Core/Type.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Build.hs
- + testsuite/tests/typecheck/should_fail/T23308.hs
- + testsuite/tests/typecheck/should_fail/T23308.stderr
- testsuite/tests/typecheck/should_fail/all.T
Changes:
=====================================
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
=====================================
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
=====================================
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
=====================================
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
=====================================
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’
=====================================
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, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c176ad1835ccfe55e2bde875b4a35e9d226ff657
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c176ad1835ccfe55e2bde875b4a35e9d226ff657
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230512/f40cd8ca/attachment-0001.html>
More information about the ghc-commits
mailing list