Emit warning if bang is applied to unlifted types

GHC will trigger a warning similar to the following when a strictness
flag is applied to an unlifted type (primitive or defined with the
Unlifted* extensions) in the definition of a data constructor.

Test.hs:7:13: warning: [-Wredundant-strictness-flags]
    • Strictness flag has no effect on unlifted type ‘Int#’
    • In the definition of data constructor ‘TestCon’
      In the data type declaration for ‘Test’
  |
7 | data Test = TestCon !Int#
  |             ^^^^^^^^^^^^^

Fixes #20187

12 files changed, 82 insertions, 3 deletions

diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index 9643579ce8..ee2074a63e 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -535,6 +535,7 @@ data WarningFlag =
    | Opt_WarnImplicitLift                 -- Since 9.2
    | Opt_WarnMissingKindSignatures        -- Since 9.2
    | Opt_WarnMissingExportedPatternSynonymSignatures -- since 9.2
+   | Opt_WarnRedundantStrictnessFlags     -- Since 9.4
    deriving (Eq, Show, Enum)
 
 -- | Return the names of a WarningFlag
@@ -615,6 +616,7 @@ warnFlagNames wflag = case wflag of
   Opt_WarnUnusedRecordWildcards                   -> "unused-record-wildcards" :| []
   Opt_WarnRedundantBangPatterns                   -> "redundant-bang-patterns" :| []
   Opt_WarnRedundantRecordWildcards                -> "redundant-record-wildcards" :| []
+  Opt_WarnRedundantStrictnessFlags                -> "redundant-strictness-flags" :| []
   Opt_WarnWrongDoBind                             -> "wrong-do-bind" :| []
   Opt_WarnMissingPatternSynonymSignatures         -> "missing-pattern-synonym-signatures" :| []
   Opt_WarnMissingDerivingStrategies               -> "missing-deriving-strategies" :| []
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 33c0fbe4cc..9c64535c77 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -3222,6 +3222,7 @@ wWarningFlagsDeps = mconcat [
   warnSpec    Opt_WarnUnusedRecordWildcards,
   warnSpec    Opt_WarnRedundantBangPatterns,
   warnSpec    Opt_WarnRedundantRecordWildcards,
+  warnSpec    Opt_WarnRedundantStrictnessFlags,
   warnSpec    Opt_WarnWrongDoBind,
   warnSpec    Opt_WarnMissingPatternSynonymSignatures,
   warnSpec    Opt_WarnMissingDerivingStrategies,
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index ef140f7e70..027c888972 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -303,6 +303,9 @@ instance Diagnostic TcRnMessage where
          in mkSimpleDecorated $ pprWithExplicitKindsWhen show_kinds $
               hang herald
                 2 (vcat (map (pprCoAxBranchUser fam_tc) (eqn1 : rest_eqns)))
+    TcRnBangOnUnliftedType ty
+      -> mkSimpleDecorated $
+           text "Strictness flag has no effect on unlifted type" <+> quotes (ppr ty)
 
   diagnosticReason = \case
     TcRnUnknownMessage m
@@ -432,6 +435,8 @@ instance Diagnostic TcRnMessage where
       -> ErrorWithoutFlag
     TcRnFamInstNotInjective{}
       -> ErrorWithoutFlag
+    TcRnBangOnUnliftedType{}
+      -> WarningWithFlag Opt_WarnRedundantStrictnessFlags
 
   diagnosticHints = \case
     TcRnUnknownMessage m
@@ -577,6 +582,8 @@ instance Diagnostic TcRnMessage where
              -> [suggestExtension LangExt.UndecidableInstances]
              | otherwise
              -> noHints
+    TcRnBangOnUnliftedType{}
+      -> noHints
 
 messageWithInfoDiagnosticMessage :: UnitState
                                  -> ErrInfo
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index d1b2ee694f..2ce13ae06f 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -916,6 +916,17 @@ data TcRnMessage where
 
   TcRnFamInstNotInjective :: InjectivityErrReason -> TyCon -> NE.NonEmpty CoAxBranch -> TcRnMessage
 
+  {-| TcRnBangOnUnliftedType is a warning (controlled by -Wredundant-strictness-flags) that
+      occurs when a strictness annotation is applied to an unlifted type.
+
+      Example(s):
+      data T = MkT !Int# -- Strictness flag has no effect on unlifted types
+
+     Test cases: typecheck/should_compile/T20187a
+                 typecheck/should_compile/T20187b
+  -}
+  TcRnBangOnUnliftedType :: !Type -> TcRnMessage
+
 -- | Which parts of a record field are affected by a particular error or warning.
 data RecordFieldPart
   = RecordFieldConstructor !Name
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index 52ef132aa3..c775acbb7d 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -4396,8 +4396,8 @@ checkValidDataCon dflags existential_ok tc con
           -- E.g.  reject   data T = MkT {-# UNPACK #-} Int     -- No "!"
           --                data T = MkT {-# UNPACK #-} !a      -- Can't unpack
         ; hsc_env <- getTopEnv
-        ; let check_bang :: HsSrcBang -> HsImplBang -> Int -> TcM ()
-              check_bang bang rep_bang n
+        ; let check_bang :: Type -> HsSrcBang -> HsImplBang -> Int -> TcM ()
+              check_bang orig_arg_ty bang rep_bang n
                | HsSrcBang _ _ SrcLazy <- bang
                , not (xopt LangExt.StrictData dflags)
                = addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $
@@ -4405,9 +4405,16 @@ checkValidDataCon dflags existential_ok tc con
 
                | HsSrcBang _ want_unpack strict_mark <- bang
                , isSrcUnpacked want_unpack, not (is_strict strict_mark)
+               , not (isUnliftedType orig_arg_ty)
                = addDiagnosticTc $ TcRnUnknownMessage $
                    mkPlainDiagnostic WarningWithoutFlag noHints (bad_bang n (text "UNPACK pragma lacks '!'"))
 
+               -- Warn about a redundant ! on an unlifted type
+               -- e.g.   data T = MkT !Int#
+               | HsSrcBang _ _ SrcStrict <- bang
+               , isUnliftedType orig_arg_ty
+               = addDiagnosticTc $ TcRnBangOnUnliftedType orig_arg_ty
+
                | HsSrcBang _ want_unpack _ <- bang
                , isSrcUnpacked want_unpack
                , case rep_bang of { HsUnpack {} -> False; _ -> True }
@@ -4428,7 +4435,8 @@ checkValidDataCon dflags existential_ok tc con
                | otherwise
                = return ()
 
-        ; zipWith3M_ check_bang (dataConSrcBangs con) (dataConImplBangs con) [1..]
+        ; void $ zipWith4M check_bang (map scaledThing $ dataConOrigArgTys con)
+          (dataConSrcBangs con) (dataConImplBangs con) [1..]
 
           -- Check the dcUserTyVarBinders invariant
           -- See Note [DataCon user type variable binders] in GHC.Core.DataCon
diff --git a/docs/users_guide/9.4.1-notes.rst b/docs/users_guide/9.4.1-notes.rst
index 2f3d822f45..aae0c065d7 100644
--- a/docs/users_guide/9.4.1-notes.rst
+++ b/docs/users_guide/9.4.1-notes.rst
@@ -3,6 +3,12 @@
 Version 9.4.1
 ==============
 
+Compiler
+~~~~~~~~
+
+- New :ghc-flag:`-Wredundant-strictness-flags` that checks for strictness flags
+  (``!``) applied to unlifted types, which are always strict.
+
 ``base`` library
 ~~~~~~~~~~~~~~~~
 
diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst
index 1f658e8167..4cae76ec5a 100644
--- a/docs/users_guide/using-warnings.rst
+++ b/docs/users_guide/using-warnings.rst
@@ -1917,6 +1917,20 @@ of ``-W(no-)*``.
 
     would report that the ``P{x, y, ..}`` match has a redundant use of ``..``.
 
+.. ghc-flag:: -Wredundant-strictness-flags
+    :shortdesc: Warn about redundant strictness flags.
+    :type: dynamic
+    :reverse: -Wno-redundant-strictness-flags
+    :category:
+
+    :since: 9.4
+
+    Report strictness flags applied to unlifted types. An unlifted type is
+    always strict, and applying a strictness flag has no effect.
+
+    For example: ::
+
+        data T = T !Int#
 
 .. ghc-flag:: -Wwrong-do-bind
     :shortdesc: warn about do bindings that appear to throw away monadic values
diff --git a/testsuite/tests/typecheck/should_compile/T20187a.hs b/testsuite/tests/typecheck/should_compile/T20187a.hs
new file mode 100644
index 0000000000..ce76330c88
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T20187a.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE MagicHash #-}
+
+module T20187a where
+
+import GHC.Exts
+
+data T = T !Int#
diff --git a/testsuite/tests/typecheck/should_compile/T20187a.stderr b/testsuite/tests/typecheck/should_compile/T20187a.stderr
new file mode 100644
index 0000000000..7fcde05809
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T20187a.stderr
@@ -0,0 +1,5 @@
+
+T20187a.hs:7:10: warning: [-Wredundant-strictness-flags]
+    • Strictness flag has no effect on unlifted type ‘Int#’
+    • In the definition of data constructor ‘T’
+      In the data type declaration for ‘T’
diff --git a/testsuite/tests/typecheck/should_compile/T20187b.hs b/testsuite/tests/typecheck/should_compile/T20187b.hs
new file mode 100644
index 0000000000..8f766cbb40
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T20187b.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE StandaloneKindSignatures, MagicHash, DataKinds, UnliftedDatatypes #-}
+
+module T20187b where
+
+import GHC.Exts
+import GHC.Types
+
+type IntU :: UnliftedType
+data IntU = IntU Int#
+
+data T = T !IntU
diff --git a/testsuite/tests/typecheck/should_compile/T20187b.stderr b/testsuite/tests/typecheck/should_compile/T20187b.stderr
new file mode 100644
index 0000000000..2f0d5c601b
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T20187b.stderr
@@ -0,0 +1,5 @@
+
+T20187b.hs:11:10: warning: [-Wredundant-strictness-flags]
+    • Strictness flag has no effect on unlifted type ‘IntU’
+    • 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 72105683a5..b6735408db 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -796,3 +796,5 @@ test('T20033', normal, compile, [''])
 test('TypeRepCon', normal, compile, ['-Woverlapping-patterns'])
 test('T20181', normal, compile, [''])
 test('T20241', normal, compile, [''])
+test('T20187a', normal, compile, ['-Wredundant-strictness-flags'])
+test('T20187b', normal, compile, ['-Wredundant-strictness-flags'])