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

8 files changed, 57 insertions, 0 deletions

diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 349f587ddc..e688010f8d 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/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{}
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 96bf0b7127..7c2b22d765 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/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.
 
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index 145f1b26f2..ee9314e74b 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/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 }
diff --git a/testsuite/tests/typecheck/should_compile/T21951a.hs b/testsuite/tests/typecheck/should_compile/T21951a.hs
new file mode 100644
index 0000000000..fb4bd85422
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T21951a.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE UnliftedDatatypes #-}
+{-# LANGUAGE StrictData #-}
+{-# LANGUAGE MagicHash #-}
+
+module Wibble where
+
+import Data.Kind
+import GHC.Exts
+
+data UA = UA ~(Array# Int)
diff --git a/testsuite/tests/typecheck/should_compile/T21951a.stderr b/testsuite/tests/typecheck/should_compile/T21951a.stderr
new file mode 100644
index 0000000000..d6afb5465e
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T21951a.stderr
@@ -0,0 +1,4 @@
+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’
diff --git a/testsuite/tests/typecheck/should_compile/T21951b.hs b/testsuite/tests/typecheck/should_compile/T21951b.hs
new file mode 100644
index 0000000000..de975e3843
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T21951b.hs
@@ -0,0 +1,13 @@
+{-# 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
diff --git a/testsuite/tests/typecheck/should_compile/T21951b.stderr b/testsuite/tests/typecheck/should_compile/T21951b.stderr
new file mode 100644
index 0000000000..f26dbe8ce2
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T21951b.stderr
@@ -0,0 +1,4 @@
+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’
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 22c5dc2647..dae6e5bca7 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/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'])