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.

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, [''])