tc: warn about lazy annotations on unlifted arguments (fixes #21951)

compiler/GHC/Tc/Errors/Ppr.hs

@@ -445,6 +445,9 @@ instance Diagnostic TcRnMessage where
     TcRnBangOnUnliftedType ty
       -> mkSimpleDecorated $
            text "Strictness flag has no effect on unlifted type" <+> quotes (ppr ty)
+    TcRnLazyBangOnUnliftedType ty
+      -> mkSimpleDecorated $
+           text "Lazy flag has no effect on unlifted type" <+> quotes (ppr ty)
     TcRnMultipleDefaultDeclarations dup_things
       -> mkSimpleDecorated $
            hang (text "Multiple default declarations")
@@ -1094,6 +1097,8 @@ instance Diagnostic TcRnMessage where
       -> ErrorWithoutFlag
     TcRnBangOnUnliftedType{}
       -> WarningWithFlag Opt_WarnRedundantStrictnessFlags
+    TcRnLazyBangOnUnliftedType{}
+      -> WarningWithFlag Opt_WarnRedundantStrictnessFlags
     TcRnMultipleDefaultDeclarations{}
       -> ErrorWithoutFlag
     TcRnBadDefaultType{}
@@ -1424,6 +1429,8 @@ instance Diagnostic TcRnMessage where
              -> noHints
     TcRnBangOnUnliftedType{}
       -> noHints
+    TcRnLazyBangOnUnliftedType{}
+      -> noHints
     TcRnMultipleDefaultDeclarations{}
       -> noHints
     TcRnBadDefaultType{}

compiler/GHC/Tc/Errors/Types.hs

@@ -1133,6 +1133,17 @@ data TcRnMessage where
   -}
   TcRnBangOnUnliftedType :: !Type -> TcRnMessage
 
+  {-| TcRnLazyBangOnUnliftedType is a warning (controlled by -Wredundant-strictness-flags) that
+      occurs when a lazy annotation is applied to an unlifted type.
+
+      Example(s):
+      data T = MkT ~Int# -- Lazy flag has no effect on unlifted types
+
+     Test cases: typecheck/should_compile/T21951a
+                 typecheck/should_compile/T21951b
+  -}
+  TcRnLazyBangOnUnliftedType :: !Type -> TcRnMessage
+
   {-| TcRnMultipleDefaultDeclarations is an error that occurs when a module has
       more than one default declaration.
 

compiler/GHC/Tc/TyCl.hs

@@ -4441,6 +4441,12 @@ checkValidDataCon dflags existential_ok tc con
                , isUnliftedType orig_arg_ty
                = addDiagnosticTc $ TcRnBangOnUnliftedType orig_arg_ty
 
+               -- Warn about a ~ on an unlifted type (#21951)
+               -- e.g.   data T = MkT ~Int#
+               | HsSrcBang _ _ SrcLazy <- bang
+               , isUnliftedType orig_arg_ty
+               = addDiagnosticTc $ TcRnLazyBangOnUnliftedType orig_arg_ty
+
                | HsSrcBang _ want_unpack _ <- bang
                , isSrcUnpacked want_unpack
                , case rep_bang of { HsUnpack {} -> False; _ -> True }

testsuite/tests/typecheck/should_compile/T21951a.hs

+{-# LANGUAGE UnliftedDatatypes #-}
+{-# LANGUAGE StrictData #-}
+{-# LANGUAGE MagicHash #-}
+
+module Wibble where
+
+import Data.Kind
+import GHC.Exts
+
+data UA = UA ~(Array# Int)

testsuite/tests/typecheck/should_compile/T21951a.stderr

+T21951a.hs:10:11: warning: [-Wredundant-strictness-flags]
+     Lazy flag has no effect on unlifted type ‘Array# Int’
+     In the definition of data constructor ‘UA’
+      In the data type declaration for ‘UA’

testsuite/tests/typecheck/should_compile/T21951b.hs

+{-# LANGUAGE UnliftedDatatypes #-}
+{-# LANGUAGE StrictData #-}
+{-# LANGUAGE MagicHash #-}
+
+module Wibble where
+
+import Data.Kind
+import GHC.Exts
+
+type U :: UnliftedType
+data U = MkU Int
+
+data T = T ~U

testsuite/tests/typecheck/should_compile/T21951b.stderr

+T21951b.hs:13:10: warning: [-Wredundant-strictness-flags]
+     Lazy flag has no effect on unlifted type ‘U’
+     In the definition of data constructor ‘T’
+      In the data type declaration for ‘T’

testsuite/tests/typecheck/should_compile/all.T

@@ -853,3 +853,5 @@ test('DeepSubsumption06', normal, compile, ['-XHaskell98'])
 test('DeepSubsumption07', normal, compile, ['-XHaskell2010'])
 test('DeepSubsumption08', normal, compile, [''])
 test('DeepSubsumption09', normal, compile, [''])
+test('T21951a', normal, compile, ['-Wredundant-strictness-flags'])
+test('T21951b', normal, compile, ['-Wredundant-strictness-flags'])