Implement -Wmissing-kind-signatureswip/ghc-9.2-merge

Fixes #19564

(cherry picked from commit 0d5d344d45c200a5e731e7d067598acd2a4f7050)

14 files changed, 297 insertions, 10 deletions

diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index 2b86c0f266..b6d20ada3a 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -511,6 +511,7 @@ data WarningFlag =
    | Opt_WarnOperatorWhitespace             -- Since 9.2
    | Opt_WarnAmbiguousFields                -- Since 9.2
    | Opt_WarnImplicitLift                 -- Since 9.2
+   | Opt_WarnMissingKindSignatures        -- Since 9.2
    deriving (Eq, Show, Enum)
 
 -- | Used when outputting warnings: if a reason is given, it is
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index eb14bbc91f..aea644aac8 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -3124,6 +3124,7 @@ wWarningFlagsDeps = [
   flagSpec "missing-monadfail-instances" Opt_WarnMissingMonadFailInstances,
   flagSpec "semigroup"                   Opt_WarnSemigroup,
   flagSpec "missing-signatures"          Opt_WarnMissingSignatures,
+  flagSpec "missing-kind-signatures"     Opt_WarnMissingKindSignatures,
   depFlagSpec "missing-exported-sigs"    Opt_WarnMissingExportedSignatures
     "it is replaced by -Wmissing-exported-signatures",
   flagSpec "missing-exported-signatures" Opt_WarnMissingExportedSignatures,
diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
index 6c99bf7b5b..835e39a246 100644
--- a/compiler/GHC/Rename/Names.hs
+++ b/compiler/GHC/Rename/Names.hs
@@ -52,6 +52,7 @@ import GHC.Parser.PostProcess ( setRdrNameSpace )
 import GHC.Core.Type
 import GHC.Core.PatSyn
 import GHC.Core.TyCo.Ppr
+import GHC.Core.TyCon ( TyCon, tyConName, tyConKind )
 import qualified GHC.LanguageExtensions as LangExt
 
 import GHC.Utils.Outputable as Outputable
@@ -1417,7 +1418,8 @@ reportUnusedNames gbl_env hsc_src
         ; traceRn "RUN" (ppr (tcg_dus gbl_env))
         ; warnUnusedImportDecls gbl_env hsc_src
         ; warnUnusedTopBinds $ unused_locals keep
-        ; warnMissingSignatures gbl_env }
+        ; warnMissingSignatures gbl_env
+        ; warnMissingKindSignatures gbl_env }
   where
     used_names :: NameSet -> NameSet
     used_names keep = findUses (tcg_dus gbl_env) emptyNameSet `unionNameSet` keep
@@ -1519,6 +1521,30 @@ warnMissingSignatures gbl_env
 
        ; add_sig_warns }
 
+-- | Warn the user about tycons that lack kind signatures.
+-- Called /after/ type (and kind) inference, so that we can report the
+-- inferred kinds.
+warnMissingKindSignatures :: TcGblEnv -> RnM ()
+warnMissingKindSignatures gbl_env
+  = do { warn_missing_kind_sigs  <- woptM Opt_WarnMissingKindSignatures
+       ; cusks_enabled <- xoptM LangExt.CUSKs
+       ; when (warn_missing_kind_sigs) (mapM_ (add_ty_warn cusks_enabled) tcs)
+       }
+  where
+    tcs = tcg_tcs gbl_env
+    ksig_ns = tcg_ksigs gbl_env
+
+    add_ty_warn :: Bool -> TyCon -> IOEnv (Env TcGblEnv TcLclEnv) ()
+    add_ty_warn cusks_enabled tyCon = when (name `elemNameSet` ksig_ns) $
+        addWarnAt (Reason Opt_WarnMissingKindSignatures) (getSrcSpan name) $
+            hang msg 2 (text "type" <+> pprPrefixName name <+> dcolon <+> ki_msg)
+      where
+        msg | cusks_enabled = text "Top-level type constructor with no standalone kind signature or CUSK:"
+            | otherwise     = text "Top-level type constructor with no standalone kind signature:"
+        name = tyConName tyCon
+        ki = tyConKind tyCon
+        ki_msg :: SDoc
+        ki_msg = pprKind ki
 
 {-
 *********************************************************
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index bcb9fa084d..d4b25806bf 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -180,7 +180,7 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
            -- Step 1: Typecheck the standalone kind signatures and type/class declarations
        ; traceTc "---- tcTyClGroup ---- {" empty
        ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds))
-       ; (tyclss, data_deriv_info) <-
+       ; (tyclss, data_deriv_info, kindless) <-
            tcExtendKindEnv (mkPromotionErrorEnv tyclds) $ -- See Note [Type environment evolution]
            do { kisig_env <- mkNameEnv <$> traverse tcStandaloneKindSig kisigs
               ; tcTyClDecls tyclds kisig_env role_annots }
@@ -214,7 +214,9 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
          tcInstDecls1 instds
 
        ; let deriv_info = datafam_deriv_info ++ data_deriv_info
-       ; return (gbl_env', inst_info, deriv_info) }
+       ; let gbl_env'' = gbl_env'
+                { tcg_ksigs = tcg_ksigs gbl_env' `unionNameSet` kindless }
+       ; return (gbl_env'', inst_info, deriv_info) }
 
 -- Gives the kind for every TyCon that has a standalone kind signature
 type KindSigEnv = NameEnv Kind
@@ -223,12 +225,12 @@ tcTyClDecls
   :: [LTyClDecl GhcRn]
   -> KindSigEnv
   -> RoleAnnotEnv
-  -> TcM ([TyCon], [DerivInfo])
+  -> TcM ([TyCon], [DerivInfo], NameSet)
 tcTyClDecls tyclds kisig_env role_annots
   = do {    -- Step 1: kind-check this group and returns the final
             -- (possibly-polymorphic) kind of each TyCon and Class
             -- See Note [Kind checking for type and class decls]
-         tc_tycons <- kcTyClGroup kisig_env tyclds
+         (tc_tycons, kindless) <- kcTyClGroup kisig_env tyclds
        ; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons))
 
             -- Step 2: type-check all groups together, returning
@@ -237,7 +239,7 @@ tcTyClDecls tyclds kisig_env role_annots
             -- NB: We have to be careful here to NOT eagerly unfold
             -- type synonyms, as we have not tested for type synonym
             -- loops yet and could fall into a black hole.
-       ; fixM $ \ ~(rec_tyclss, _) -> do
+       ; fixM $ \ ~(rec_tyclss, _, _) -> do
            { tcg_env <- getGblEnv
                  -- Forced so we don't retain a reference to the TcGblEnv
            ; let !src  = tcg_src tcg_env
@@ -258,7 +260,7 @@ tcTyClDecls tyclds kisig_env role_annots
 
                  -- Kind and type check declarations for this group
                mapAndUnzipM (tcTyClDecl roles) tyclds
-           ; return (tycons, concat data_deriv_infos)
+           ; return (tycons, concat data_deriv_infos, kindless)
            } }
   where
     ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma
@@ -631,12 +633,14 @@ been generalized.
 
 -}
 
-kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM [TcTyCon]
+kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM ([TcTyCon], NameSet)
 
 -- Kind check this group, kind generalize, and return the resulting local env
 -- This binds the TyCons and Classes of the group, but not the DataCons
 -- See Note [Kind checking for type and class decls]
 -- and Note [Inferring kinds for type declarations]
+--
+-- The NameSet returned contains kindless tycon names, without CUSK or SAKS.
 kcTyClGroup kisig_env decls
   = do  { mod <- getModule
         ; traceTc "---- kcTyClGroup ---- {"
@@ -651,9 +655,12 @@ kcTyClGroup kisig_env decls
         ; cusks_enabled <- xoptM LangExt.CUSKs <&&> xoptM LangExt.PolyKinds
                     -- See Note [CUSKs and PolyKinds]
         ; let (kindless_decls, kinded_decls) = partitionWith get_kind decls
+              kindless_names = mkNameSet $ map get_name kindless_decls
+
+              get_name d = tcdName (unLoc d)
 
               get_kind d
-                | Just ki <- lookupNameEnv kisig_env (tcdName (unLoc d))
+                | Just ki <- lookupNameEnv kisig_env (get_name d)
                 = Right (d, SAKS ki)
 
                 | cusks_enabled && hsDeclHasCusk (unLoc d)
@@ -700,7 +707,7 @@ kcTyClGroup kisig_env decls
 
         ; let poly_tcs = checked_tcs ++ generalized_tcs
         ; traceTc "---- kcTyClGroup end ---- }" (ppr_tc_kinds poly_tcs)
-        ; return poly_tcs }
+        ; return (poly_tcs, kindless_names) }
   where
     ppr_tc_kinds tcs = vcat (map pp_tc tcs)
     pp_tc tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc)
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index 5da6364444..dbed564efc 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -540,6 +540,7 @@ data TcGblEnv
         tcg_warns     :: Warnings,           -- ...Warnings and deprecations
         tcg_anns      :: [Annotation],       -- ...Annotations
         tcg_tcs       :: [TyCon],            -- ...TyCons and Classes
+        tcg_ksigs     :: NameSet,            -- ...Top-level TyCon names that *lack* a signature
         tcg_insts     :: [ClsInst],          -- ...Instances
         tcg_fam_insts :: [FamInst],          -- ...Family instances
         tcg_rules     :: [LRuleDecl GhcTc],  -- ...Rules
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 1a70f0ecbd..b79200c288 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -322,6 +322,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcg_binds          = emptyLHsBinds,
                 tcg_imp_specs      = [],
                 tcg_sigs           = emptyNameSet,
+                tcg_ksigs          = emptyNameSet,
                 tcg_ev_binds       = emptyBag,
                 tcg_warns          = NoWarnings,
                 tcg_anns           = [],
diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst
index 9771837b93..4c1a01f6db 100644
--- a/docs/users_guide/using-warnings.rst
+++ b/docs/users_guide/using-warnings.rst
@@ -114,6 +114,7 @@ The following flags are simple ways to select standard "packages" of warnings:
         * :ghc-flag:`-Wunused-type-patterns`
         * :ghc-flag:`-Wsafe`
         * :ghc-flag:`-Wimplicit-lift`
+        * :ghc-flag:`-Wmissing-kind-signatures`
 
 .. ghc-flag:: -Weverything
     :shortdesc: enable all warnings supported by GHC
@@ -1182,6 +1183,32 @@ of ``-W(no-)*``.
     synonyms must have a type signature. GHC also reports the inferred
     type. This option is off by default.
 
+.. ghc-flag:: -Wmissing-kind-signatures
+    :shortdesc: warn when type declarations don't have kind signatures nor CUSKs
+    :type: dynamic
+    :reverse: -Wno-missing-kind-signatures
+    :category:
+
+    :since: 9.2
+
+    .. index::
+         single: kind signatures, missing
+
+    If you would like GHC to check that every data, type family,
+    type-class definition has a :ref:`standalone kind signature <standalone-kind-signatures>` or a :ref:`CUSK <complete-kind-signatures>`, use the
+    :ghc-flag:`-Wmissing-kind-signatures` option.
+    You can specify the kind via :extension:`StandaloneKindSignatures`
+    or :extension:`CUSKs`.
+
+    Note that :ghc-flag:`-Wmissing-kind-signatures` does not warn about
+    associated type families, as GHC considers an associated type family
+    declaration to have a CUSK if its enclosing class has a CUSK. (See
+    :ref:`complete-kind-signatures` for more on this point.) Therefore, giving
+    the parent class a standalone kind signature or CUSK is sufficient to fix
+    the warning for the class's associated type families as well.
+
+    This option is off by default.
+
 .. ghc-flag:: -Wname-shadowing
     :shortdesc: warn when names are shadowed
     :type: dynamic
diff --git a/testsuite/tests/warnings/should_compile/T19564a.hs b/testsuite/tests/warnings/should_compile/T19564a.hs
new file mode 100644
index 0000000000..462d82cc42
--- /dev/null
+++ b/testsuite/tests/warnings/should_compile/T19564a.hs
@@ -0,0 +1,32 @@
+{-# OPTIONS_GHC -Wmissing-kind-signatures #-}
+{-# LANGUAGE GADTs, PolyKinds, TypeFamilies #-}
+-- without standalone kind signatures or cusks: warnings
+module T19564a where
+
+-- type family
+type family Id x where
+    Id Int = Int
+
+-- class definition
+class Functor f => Alt f where
+    (<!>) :: f a -> f a -> f a
+
+-- type alias
+type Arr a b = a -> b
+type B = Bool
+
+-- Haskell98 data
+data YesNo = Yes | No
+data V2 a = V2 a a
+
+-- GADT
+data Free f a where
+    Pure :: a -> Free f a
+    Ap   :: f b -> Free f (b -> a) -> Free f a
+
+-- data family
+data family D1 a
+
+-- associated type family
+class C a where
+    type AT a b
diff --git a/testsuite/tests/warnings/should_compile/T19564a.stderr b/testsuite/tests/warnings/should_compile/T19564a.stderr
new file mode 100644
index 0000000000..f64805fa31
--- /dev/null
+++ b/testsuite/tests/warnings/should_compile/T19564a.stderr
@@ -0,0 +1,36 @@
+
+T19564a.hs:7:1: warning: [-Wmissing-kind-signatures]
+    Top-level type constructor with no standalone kind signature:
+      type Id :: * -> *
+
+T19564a.hs:11:1: warning: [-Wmissing-kind-signatures]
+    Top-level type constructor with no standalone kind signature:
+      type Alt :: (* -> *) -> Constraint
+
+T19564a.hs:15:1: warning: [-Wmissing-kind-signatures]
+    Top-level type constructor with no standalone kind signature:
+      type Arr :: * -> * -> *
+
+T19564a.hs:16:1: warning: [-Wmissing-kind-signatures]
+    Top-level type constructor with no standalone kind signature:
+      type B :: *
+
+T19564a.hs:19:1: warning: [-Wmissing-kind-signatures]
+    Top-level type constructor with no standalone kind signature:
+      type YesNo :: *
+
+T19564a.hs:20:1: warning: [-Wmissing-kind-signatures]
+    Top-level type constructor with no standalone kind signature:
+      type V2 :: * -> *
+
+T19564a.hs:23:1: warning: [-Wmissing-kind-signatures]
+    Top-level type constructor with no standalone kind signature:
+      type Free :: (* -> *) -> * -> *
+
+T19564a.hs:28:1: warning: [-Wmissing-kind-signatures]
+    Top-level type constructor with no standalone kind signature:
+      type D1 :: * -> *
+
+T19564a.hs:31:1: warning: [-Wmissing-kind-signatures]
+    Top-level type constructor with no standalone kind signature:
+      type C :: forall {k}. k -> Constraint
diff --git a/testsuite/tests/warnings/should_compile/T19564b.hs b/testsuite/tests/warnings/should_compile/T19564b.hs
new file mode 100644
index 0000000000..a981e9f61c
--- /dev/null
+++ b/testsuite/tests/warnings/should_compile/T19564b.hs
@@ -0,0 +1,46 @@
+{-# OPTIONS_GHC -Wmissing-kind-signatures #-}
+{-# LANGUAGE GADTs, PolyKinds, TypeFamilies #-}
+-- with kind signatures: no warnings
+module T19564b where
+
+import Data.Kind (Type, Constraint)
+
+-- type family
+type Id :: Type -> Type
+type family Id x where
+    Id Int = Int
+
+-- class definition
+type Alt :: (Type -> Type) -> Constraint
+class Functor f => Alt f where
+    (<!>) :: f a -> f a -> f a
+
+-- type alias
+type Arr :: Type -> Type -> Type
+type Arr a b = a -> b
+
+type B :: Type
+type B = Bool
+
+-- Haskell98 data
+type YesNo :: Type
+data YesNo = Yes | No
+
+type V2 :: Type -> Type
+data V2 a = V2 a a
+
+-- GADT
+type Free :: (Type -> Type) -> (Type -> Type)
+data Free f a where
+    Pure :: a -> Free f a
+    Ap   :: f b -> Free f (b -> a) -> Free f a
+
+-- data family
+type D1 :: Type -> Type
+data family D1 a
+
+-- associated type family
+type C :: Type -> Constraint
+class C a where
+    -- is defaulted, doesn't need annotation
+    type AT a b
diff --git a/testsuite/tests/warnings/should_compile/T19564c.hs b/testsuite/tests/warnings/should_compile/T19564c.hs
new file mode 100644
index 0000000000..6f950b7307
--- /dev/null
+++ b/testsuite/tests/warnings/should_compile/T19564c.hs
@@ -0,0 +1,34 @@
+{-# OPTIONS_GHC -Wmissing-kind-signatures #-}
+{-# LANGUAGE GADTs, PolyKinds, TypeFamilies #-}
+-- with cusks but without -XCUSK, warnings
+module T19564c where
+
+import Data.Kind (Type, Constraint)
+
+-- type family
+type family Id (x :: Type) :: Type where
+    Id Int = Int
+
+-- class definition
+class Functor f => Alt (f :: Type -> Type) where
+    (<!>) :: f a -> f a -> f a
+
+-- type alias
+type Arr (a :: Type) (b :: Type) = a -> b :: Type
+type B = Bool :: Type
+
+-- Haskell98 data
+data YesNo = Yes | No
+data V2 (a :: Type) = V2 a a
+
+-- GADT
+data Free (f :: Type -> Type) (a :: Type) where
+    Pure :: a -> Free f a
+    Ap   :: f b -> Free f (b -> a) -> Free f a
+
+-- data family
+data family D1 (a :: Type)
+
+-- associated type family
+class C (a :: Type) where
+    type AT a b
diff --git a/testsuite/tests/warnings/should_compile/T19564c.stderr b/testsuite/tests/warnings/should_compile/T19564c.stderr
new file mode 100644
index 0000000000..587ea089fc
--- /dev/null
+++ b/testsuite/tests/warnings/should_compile/T19564c.stderr
@@ -0,0 +1,36 @@
+
+T19564c.hs:9:1: warning: [-Wmissing-kind-signatures]
+    Top-level type constructor with no standalone kind signature:
+      type Id :: * -> *
+
+T19564c.hs:13:1: warning: [-Wmissing-kind-signatures]
+    Top-level type constructor with no standalone kind signature:
+      type Alt :: (* -> *) -> Constraint
+
+T19564c.hs:17:1: warning: [-Wmissing-kind-signatures]
+    Top-level type constructor with no standalone kind signature:
+      type Arr :: * -> * -> *
+
+T19564c.hs:18:1: warning: [-Wmissing-kind-signatures]
+    Top-level type constructor with no standalone kind signature:
+      type B :: *
+
+T19564c.hs:21:1: warning: [-Wmissing-kind-signatures]
+    Top-level type constructor with no standalone kind signature:
+      type YesNo :: *
+
+T19564c.hs:22:1: warning: [-Wmissing-kind-signatures]
+    Top-level type constructor with no standalone kind signature:
+      type V2 :: * -> *
+
+T19564c.hs:25:1: warning: [-Wmissing-kind-signatures]
+    Top-level type constructor with no standalone kind signature:
+      type Free :: (* -> *) -> * -> *
+
+T19564c.hs:30:1: warning: [-Wmissing-kind-signatures]
+    Top-level type constructor with no standalone kind signature:
+      type D1 :: * -> *
+
+T19564c.hs:33:1: warning: [-Wmissing-kind-signatures]
+    Top-level type constructor with no standalone kind signature:
+      type C :: * -> Constraint
diff --git a/testsuite/tests/warnings/should_compile/T19564d.hs b/testsuite/tests/warnings/should_compile/T19564d.hs
new file mode 100644
index 0000000000..599f5bbc6a
--- /dev/null
+++ b/testsuite/tests/warnings/should_compile/T19564d.hs
@@ -0,0 +1,34 @@
+{-# OPTIONS_GHC -Wmissing-kind-signatures #-}
+{-# LANGUAGE GADTs, PolyKinds, TypeFamilies, CUSKs #-}
+-- with -XCUSKs, no warnings
+module T19564c where
+
+import Data.Kind (Type, Constraint)
+
+-- type family
+type family Id (x :: Type) :: Type where
+    Id Int = Int
+
+-- class definition
+class Functor f => Alt (f :: Type -> Type) where
+    (<!>) :: f a -> f a -> f a
+
+-- type alias
+type Arr (a :: Type) (b :: Type) = a -> b :: Type
+type B = Bool :: Type
+
+-- Haskell98 data
+data YesNo = Yes | No
+data V2 (a :: Type) = V2 a a
+
+-- GADT
+data Free (f :: Type -> Type) (a :: Type) where
+    Pure :: a -> Free f a
+    Ap   :: f b -> Free f (b -> a) -> Free f a
+
+-- data family
+data family D1 (a :: Type)
+
+-- associated type family
+class C (a :: Type) where
+    type AT a b
diff --git a/testsuite/tests/warnings/should_compile/all.T b/testsuite/tests/warnings/should_compile/all.T
index 7e8668c8d8..f1739aebc3 100644
--- a/testsuite/tests/warnings/should_compile/all.T
+++ b/testsuite/tests/warnings/should_compile/all.T
@@ -38,3 +38,8 @@ test('UnusedPackages', normal, multimod_compile,
     ['UnusedPackages.hs', '-package=bytestring -package=base -package=process -package=ghc -Wunused-packages'])
 
 test('T18402', normal, compile, [''])
+
+test('T19564a', normal, compile, [''])
+test('T19564b', normal, compile, [''])
+test('T19564c', normal, compile, [''])
+test('T19564d', normal, compile, [''])