diff options
author | Ryan Scott <ryan.gl.scott@gmail.com> | 2023-02-12 08:42:23 -0500 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2023-03-10 02:11:16 -0500 |
commit | 3417206641467f0a38e41410df52a3a55fe5b65a (patch) | |
tree | 511d46e99fd01b2673a3292b2c6ae30b6ff286aa | |
parent | d81d0a0e8ed6cf35b9772404ce9d7f109481bcd6 (diff) | |
download | haskell-3417206641467f0a38e41410df52a3a55fe5b65a.tar.gz |
Disallow `tagToEnum#` on `type data` types
We don't want to allow users to conjure up values of a `type data` type using
`tagToEnum#`, as these simply don't exist at the value level.
(cherry picked from commit ff8e99f69b203559b784014ab26c59b5553d128a)
-rw-r--r-- | compiler/GHC/Rename/Module.hs | 11 | ||||
-rw-r--r-- | compiler/GHC/Tc/Errors/Ppr.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Tc/Errors/Types.hs | 14 | ||||
-rw-r--r-- | compiler/GHC/Tc/Gen/App.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Types/Error/Codes.hs | 1 | ||||
-rw-r--r-- | testsuite/tests/type-data/should_fail/TDTagToEnum.hs | 10 | ||||
-rw-r--r-- | testsuite/tests/type-data/should_fail/TDTagToEnum.stderr | 6 | ||||
-rw-r--r-- | testsuite/tests/type-data/should_fail/all.T | 1 |
8 files changed, 53 insertions, 0 deletions
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index bc14c1b189..ad8031ecb6 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -2176,6 +2176,17 @@ The main parts of the implementation are: * In `GHC.Core.Utils.refineDataAlt`, do /not/ fill in the DEFAULT case with the data constructor. See Note [Refine DEFAULT case alternatives] Exception 2, in GHC.Core.Utils. + +* To prevent users from conjuring up `type data` values at the term level, we + disallow using the tagToEnum# function on a type headed by a `type data` + type. For instance, GHC will reject this code: + + type data Letter = A | B | C + + f :: Letter + f = tagToEnum# 0# + + See `GHC.Tc.Gen.App.checkTagToEnum`, specifically `check_enumeration`. -} warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn) diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index 86c5e05456..946b028e00 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -276,6 +276,10 @@ instance Diagnostic TcRnMessage where -> mkSimpleDecorated $ hang (text "Bad call to tagToEnum# at type" <+> ppr ty) 2 (text "Result type must be an enumeration type") + TcRnTagToEnumResTyTypeData ty + -> mkSimpleDecorated $ + hang (text "Bad call to tagToEnum# at type" <+> ppr ty) + 2 (text "Result type cannot be headed by a `type data` type") TcRnArrowIfThenElsePredDependsOnResultTy -> mkSimpleDecorated $ text "Predicate type of `ifThenElse' depends on result type" @@ -1307,6 +1311,8 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnTagToEnumResTyNotAnEnum{} -> ErrorWithoutFlag + TcRnTagToEnumResTyTypeData{} + -> ErrorWithoutFlag TcRnArrowIfThenElsePredDependsOnResultTy -> ErrorWithoutFlag TcRnIllegalHsBootFileDecl @@ -1713,6 +1719,8 @@ instance Diagnostic TcRnMessage where -> noHints TcRnTagToEnumResTyNotAnEnum{} -> noHints + TcRnTagToEnumResTyTypeData{} + -> noHints TcRnArrowIfThenElsePredDependsOnResultTy -> noHints TcRnIllegalHsBootFileDecl diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index 70431b121d..f52dfe58c6 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -663,6 +663,20 @@ data TcRnMessage where -} TcRnTagToEnumResTyNotAnEnum :: Type -> TcRnMessage + {-| TcRnTagToEnumResTyTypeData is an error that occurs when the 'tagToEnum#' + function is given a result type that is headed by a @type data@ type, as + the data constructors of a @type data@ do not exist at the term level. + + Example(s): + type data Letter = A | B | C + + foo :: Letter + foo = tagToEnum# 0# + + Test cases: type-data/should_fail/TDTagToEnum.hs + -} + TcRnTagToEnumResTyTypeData :: Type -> TcRnMessage + {-| TcRnArrowIfThenElsePredDependsOnResultTy is an error that occurs when the predicate type of an ifThenElse expression in arrow notation depends on the type of the result. diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs index 06158cace3..ccaf2f18e0 100644 --- a/compiler/GHC/Tc/Gen/App.hs +++ b/compiler/GHC/Tc/Gen/App.hs @@ -1226,6 +1226,8 @@ tcTagToEnum tc_fun fun_ctxt tc_args res_ty vanilla_result = rebuildHsApps tc_fun fun_ctxt tc_args res_ty check_enumeration ty' tc + | -- isTypeDataTyCon: see Note [Type data declarations] in GHC.Rename.Module + isTypeDataTyCon tc = addErrTc (TcRnTagToEnumResTyTypeData ty') | isEnumerationTyCon tc = return () | otherwise = addErrTc (TcRnTagToEnumResTyNotAnEnum ty') diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs index 981e2c7d0a..0072f91030 100644 --- a/compiler/GHC/Types/Error/Codes.hs +++ b/compiler/GHC/Types/Error/Codes.hs @@ -354,6 +354,7 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "TcRnTagToEnumMissingValArg" = 36495 GhcDiagnosticCode "TcRnTagToEnumUnspecifiedResTy" = 08522 GhcDiagnosticCode "TcRnTagToEnumResTyNotAnEnum" = 49356 + GhcDiagnosticCode "TcRnTagToEnumResTyTypeData" = 96189 GhcDiagnosticCode "TcRnArrowIfThenElsePredDependsOnResultTy" = 55868 GhcDiagnosticCode "TcRnIllegalHsBootFileDecl" = 58195 GhcDiagnosticCode "TcRnRecursivePatternSynonym" = 72489 diff --git a/testsuite/tests/type-data/should_fail/TDTagToEnum.hs b/testsuite/tests/type-data/should_fail/TDTagToEnum.hs new file mode 100644 index 0000000000..ef0ba0b496 --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDTagToEnum.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeData #-} +module TDTagToEnum where + +import GHC.Exts (tagToEnum#) + +type data Letter = A | B | C + +f :: Letter +f = tagToEnum# 0# diff --git a/testsuite/tests/type-data/should_fail/TDTagToEnum.stderr b/testsuite/tests/type-data/should_fail/TDTagToEnum.stderr new file mode 100644 index 0000000000..d8ddbbeb47 --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDTagToEnum.stderr @@ -0,0 +1,6 @@ + +TDTagToEnum.hs:10:5: error: [GHC-96189] + ⢠Bad call to tagToEnum# at type Letter + Result type cannot be headed by a `type data` type + ⢠In the expression: tagToEnum# 0# + In an equation for âfâ: f = tagToEnum# 0# diff --git a/testsuite/tests/type-data/should_fail/all.T b/testsuite/tests/type-data/should_fail/all.T index 82b257df22..870e4ea991 100644 --- a/testsuite/tests/type-data/should_fail/all.T +++ b/testsuite/tests/type-data/should_fail/all.T @@ -11,4 +11,5 @@ test('TDRecordsH98', normal, compile_fail, ['']) test('TDRecursive', normal, compile_fail, ['']) test('TDStrictnessGADT', normal, compile_fail, ['']) test('TDStrictnessH98', normal, compile_fail, ['']) +test('TDTagToEnum', normal, compile_fail, ['']) test('T22332b', normal, compile_fail, ['']) |