summaryrefslogtreecommitdiff
path: root/compiler/GHC
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC')
-rw-r--r--compiler/GHC/Driver/Flags.hs1
-rw-r--r--compiler/GHC/Driver/Session.hs1
-rw-r--r--compiler/GHC/Rename/Names.hs28
-rw-r--r--compiler/GHC/Tc/TyCl.hs25
-rw-r--r--compiler/GHC/Tc/Types.hs1
-rw-r--r--compiler/GHC/Tc/Utils/Monad.hs1
6 files changed, 47 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 = [],
View Lorry Controller Status