summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRyan Scott <ryan.gl.scott@gmail.com>2023-02-12 08:42:23 -0500
committerRyan Scott <ryan.gl.scott@gmail.com>2023-02-20 20:44:35 -0500
commitff8e99f69b203559b784014ab26c59b5553d128a (patch)
tree6a997080020bfb1d217861df268f830311467ce1
parent96dc58b9225d91a7912957c6be5d9c7a95e51718 (diff)
downloadhaskell-ff8e99f69b203559b784014ab26c59b5553d128a.tar.gz
Disallow `tagToEnum#` on `type data` typeswip/T22948
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.
-rw-r--r--compiler/GHC/Rename/Module.hs11
-rw-r--r--compiler/GHC/Tc/Errors/Ppr.hs8
-rw-r--r--compiler/GHC/Tc/Errors/Types.hs14
-rw-r--r--compiler/GHC/Tc/Gen/App.hs2
-rw-r--r--compiler/GHC/Types/Error/Codes.hs1
-rw-r--r--testsuite/tests/type-data/should_fail/TDTagToEnum.hs10
-rw-r--r--testsuite/tests/type-data/should_fail/TDTagToEnum.stderr6
-rw-r--r--testsuite/tests/type-data/should_fail/all.T1
8 files changed, 53 insertions, 0 deletions
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index e9b8d40d83..fd9792744c 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -2169,6 +2169,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 10d1c60fb1..02acd47e2e 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -277,6 +277,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"
@@ -1391,6 +1395,8 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnTagToEnumResTyNotAnEnum{}
-> ErrorWithoutFlag
+ TcRnTagToEnumResTyTypeData{}
+ -> ErrorWithoutFlag
TcRnArrowIfThenElsePredDependsOnResultTy
-> ErrorWithoutFlag
TcRnIllegalHsBootFileDecl
@@ -1821,6 +1827,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 e2707b4aa4..0420a4e498 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -665,6 +665,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 c8c1730b35..44a35028cd 100644
--- a/compiler/GHC/Tc/Gen/App.hs
+++ b/compiler/GHC/Tc/Gen/App.hs
@@ -1222,6 +1222,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 bae5e1ccfb..9d3fe30084 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, [''])