diff options
author | Oleg Grenrus <oleg.grenrus@iki.fi> | 2021-03-21 01:52:07 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-03-25 17:36:50 -0400 |
commit | 0d5d344d45c200a5e731e7d067598acd2a4f7050 (patch) | |
tree | 462b5671404a9011e9609534739ca42ca5de5502 /compiler/GHC | |
parent | c74bd3daa3468e495714647506cf30cf650d390d (diff) | |
download | haskell-0d5d344d45c200a5e731e7d067598acd2a4f7050.tar.gz |
Implement -Wmissing-kind-signatures
Fixes #19564
Diffstat (limited to 'compiler/GHC')
-rw-r--r-- | compiler/GHC/Driver/Flags.hs | 1 | ||||
-rw-r--r-- | compiler/GHC/Driver/Session.hs | 1 | ||||
-rw-r--r-- | compiler/GHC/Rename/Names.hs | 28 | ||||
-rw-r--r-- | compiler/GHC/Tc/TyCl.hs | 25 | ||||
-rw-r--r-- | compiler/GHC/Tc/Types.hs | 1 | ||||
-rw-r--r-- | compiler/GHC/Tc/Utils/Monad.hs | 1 |
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 = [], |