Commit 1bd40c86 authored by Eric Seidel's avatar Eric Seidel Committed by Ben Gamari

Move checking for missing signatures to RnNames.reportUnusedNames

Checking for missing signatures before renaming the export list is
prone to errors, so we now perform the check in `reportUnusedNames` at
which point everything has been renamed.

Test Plan: validate, new test case is T10908

Reviewers: goldfire, simonpj, austin, bgamari

Subscribers: thomie

Projects: #ghc

Differential Revision: https://phabricator.haskell.org/D1561

GHC Trac Issues: #10908
parent 51a5e68d
......@@ -43,6 +43,8 @@ import Util
import FastString
import FastStringEnv
import ListSetOps
import Id
import Type
import Control.Monad
import Data.Either ( partitionEithers, isRight, rights )
......@@ -1471,7 +1473,8 @@ reportUnusedNames :: Maybe (Located [LIE RdrName]) -- Export list
reportUnusedNames _export_decls gbl_env
= do { traceRn ((text "RUN") <+> (ppr (tcg_dus gbl_env)))
; warnUnusedImportDecls gbl_env
; warnUnusedTopBinds unused_locals }
; warnUnusedTopBinds unused_locals
; warnMissingSigs gbl_env }
where
used_names :: NameSet
used_names = findUses (tcg_dus gbl_env) emptyNameSet
......@@ -1546,6 +1549,64 @@ warnUnusedImportDecls gbl_env
; whenGOptM Opt_D_dump_minimal_imports $
printMinimalImports usage }
-- | Warn the user about top level binders that lack type signatures.
warnMissingSigs :: TcGblEnv -> RnM ()
warnMissingSigs gbl_env
= do { let exports = availsToNameSet (tcg_exports gbl_env)
sig_ns = tcg_sigs gbl_env
binds = tcg_binds gbl_env
-- Warn about missing signatures
-- Do this only when we we have a type to offer
; warn_missing_sigs <- woptM Opt_WarnMissingSigs
; warn_only_exported <- woptM Opt_WarnMissingExportedSigs
; let sig_warn
| warn_only_exported = topSigWarnIfExported exports sig_ns
| warn_missing_sigs = topSigWarn sig_ns
| otherwise = noSigWarn
; sig_warn (collectHsBindsBinders binds) }
type SigWarn = [Id] -> RnM ()
-- Missing-signature warning
noSigWarn :: SigWarn
noSigWarn _ = return ()
topSigWarnIfExported :: NameSet -> NameSet -> SigWarn
topSigWarnIfExported exported sig_ns ids
= mapM_ (topSigWarnIdIfExported exported sig_ns) ids
topSigWarnIdIfExported :: NameSet -> NameSet -> Id -> RnM ()
topSigWarnIdIfExported exported sig_ns id
| getName id `elemNameSet` exported
= topSigWarnId sig_ns id
| otherwise
= return ()
topSigWarn :: NameSet -> SigWarn
topSigWarn sig_ns ids = mapM_ (topSigWarnId sig_ns) ids
topSigWarnId :: NameSet -> Id -> RnM ()
-- The NameSet is the Ids that *lack* a signature
-- We have to do it this way round because there are
-- lots of top-level bindings that are generated by GHC
-- and that don't have signatures
topSigWarnId sig_ns id
| idName id `elemNameSet` sig_ns = warnMissingSig msg id
| otherwise = return ()
where
msg = ptext (sLit "Top-level binding with no type signature:")
warnMissingSig :: SDoc -> Id -> RnM ()
warnMissingSig msg id
= do { env <- tcInitTidyEnv
; let (_, tidy_ty) = tidyOpenType env (idType id)
; addWarnAt (getSrcSpan id) (mk_msg tidy_ty) }
where
mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]
{-
Note [The ImportMap]
~~~~~~~~~~~~~~~~~~~~
......
......@@ -58,7 +58,7 @@ import Util
import BasicTypes
import Outputable
import FastString
import Type(mkStrLitTy)
import Type(mkStrLitTy, tidyOpenType)
import PrelNames( mkUnboundName, gHC_PRIM )
import TcValidity (checkValidType)
......@@ -728,6 +728,10 @@ mkExport prag_fn qtvs theta mono_info@(poly_name, mb_sig, mono_id)
-- e..g infer x :: forall a. F a -> Int
else addErrCtxtM (mk_impedence_match_msg mono_info sel_poly_ty poly_ty) $
tcSubType_NC sig_ctxt sel_poly_ty poly_ty
; warn_missing_sigs <- woptM Opt_WarnMissingLocalSigs
; when warn_missing_sigs $ localSigWarn poly_id mb_sig
; return (ABE { abe_wrap = wrap
-- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty)
, abe_poly = poly_id
......@@ -852,6 +856,24 @@ mk_inf_msg poly_name poly_ty tidy_env
, nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ]
; return (tidy_env1, msg) }
-- | Warn the user about polymorphic local binders that lack type signatures.
localSigWarn :: Id -> Maybe TcIdSigInfo -> TcM ()
localSigWarn id mb_sig
| Just _ <- mb_sig = return ()
| not (isSigmaTy (idType id)) = return ()
| otherwise = warnMissingSig msg id
where
msg = ptext (sLit "Polymorphic local binding with no type signature:")
warnMissingSig :: SDoc -> Id -> TcM ()
warnMissingSig msg id
= do { env0 <- tcInitTidyEnv
; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
; addWarnTcM (env1, mk_msg tidy_ty) }
where
mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]
{-
Note [Partial type signatures and generalisation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -36,7 +36,6 @@ import TcRnMonad
import PrelNames
import TypeRep -- We can see the representation of types
import TcType
import RdrName ( RdrName, rdrNameOcc )
import TcMType ( defaultKindVarToStar, zonkQuantifiedTyVar, writeMetaTyVar )
import TcEvidence
import Coercion
......@@ -46,7 +45,6 @@ import Type
import ConLike
import DataCon
import Name
import NameSet
import Var
import VarSet
import VarEnv
......@@ -56,7 +54,6 @@ import BasicTypes
import Maybes
import SrcLoc
import Bag
import FastString
import Outputable
import Util
#if __GLASGOW_HASKELL__ < 709
......@@ -299,8 +296,6 @@ zonkTopLExpr e = zonkLExpr emptyZonkEnv e
zonkTopDecls :: Bag EvBind
-> LHsBinds TcId
-> Maybe (Located [LIE RdrName])
-> NameSet
-> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId]
-> TcM ([Id],
Bag EvBind,
......@@ -309,22 +304,9 @@ zonkTopDecls :: Bag EvBind
[LTcSpecPrag],
[LRuleDecl Id],
[LVectDecl Id])
zonkTopDecls ev_binds binds export_ies sig_ns rules vects imp_specs fords
zonkTopDecls ev_binds binds rules vects imp_specs fords
= do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
-- Warn about missing signatures
-- Do this only when we we have a type to offer
; warn_missing_sigs <- woptM Opt_WarnMissingSigs
; warn_only_exported <- woptM Opt_WarnMissingExportedSigs
; let export_occs = maybe emptyBag
(listToBag . concatMap (map rdrNameOcc . ieNames . unLoc) . unLoc)
export_ies
sig_warn
| warn_only_exported = topSigWarnIfExported export_occs sig_ns
| warn_missing_sigs = topSigWarn sig_ns
| otherwise = noSigWarn
; (env2, binds') <- zonkRecMonoBinds env1 sig_warn binds
; (env2, binds') <- zonkRecMonoBinds env1 binds
-- Top level is implicitly recursive
; rules' <- zonkRules env2 rules
; vects' <- zonkVects env2 vects
......@@ -340,19 +322,15 @@ zonkLocalBinds env EmptyLocalBinds
zonkLocalBinds _ (HsValBinds (ValBindsIn {}))
= panic "zonkLocalBinds" -- Not in typechecker output
zonkLocalBinds env (HsValBinds vb@(ValBindsOut binds sigs))
= do { warn_missing_sigs <- woptM Opt_WarnMissingLocalSigs
; let sig_warn | not warn_missing_sigs = noSigWarn
| otherwise = localSigWarn sig_ns
sig_ns = getTypeSigNames vb
; (env1, new_binds) <- go env sig_warn binds
zonkLocalBinds env (HsValBinds (ValBindsOut binds sigs))
= do { (env1, new_binds) <- go env binds
; return (env1, HsValBinds (ValBindsOut new_binds sigs)) }
where
go env _ []
go env []
= return (env, [])
go env sig_warn ((r,b):bs)
= do { (env1, b') <- zonkRecMonoBinds env sig_warn b
; (env2, bs') <- go env1 sig_warn bs
go env ((r,b):bs)
= do { (env1, b') <- zonkRecMonoBinds env b
; (env2, bs') <- go env1 bs
; return (env2, (r,b'):bs') }
zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = do
......@@ -368,112 +346,53 @@ zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = do
return (IPBind n' e')
---------------------------------------------
zonkRecMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
zonkRecMonoBinds env sig_warn binds
zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
zonkRecMonoBinds env binds
= fixM (\ ~(_, new_binds) -> do
{ let env1 = extendIdZonkEnv env (collectHsBindsBinders new_binds)
; binds' <- zonkMonoBinds env1 sig_warn binds
; binds' <- zonkMonoBinds env1 binds
; return (env1, binds') })
---------------------------------------------
type SigWarn = Bool -> [Id] -> TcM ()
-- Missing-signature warning
-- The Bool is True for an AbsBinds, False otherwise
noSigWarn :: SigWarn
noSigWarn _ _ = return ()
topSigWarnIfExported :: Bag OccName -> NameSet -> SigWarn
topSigWarnIfExported exported sig_ns _ ids
= mapM_ (topSigWarnIdIfExported exported sig_ns) ids
topSigWarnIdIfExported :: Bag OccName -> NameSet -> Id -> TcM ()
topSigWarnIdIfExported exported sig_ns id
| getOccName id `elemBag` exported
= topSigWarnId sig_ns id
| otherwise
= return ()
topSigWarn :: NameSet -> SigWarn
topSigWarn sig_ns _ ids = mapM_ (topSigWarnId sig_ns) ids
topSigWarnId :: NameSet -> Id -> TcM ()
-- The NameSet is the Ids that *lack* a signature
-- We have to do it this way round because there are
-- lots of top-level bindings that are generated by GHC
-- and that don't have signatures
topSigWarnId sig_ns id
| idName id `elemNameSet` sig_ns = warnMissingSig msg id
| otherwise = return ()
where
msg = ptext (sLit "Top-level binding with no type signature:")
localSigWarn :: NameSet -> SigWarn
localSigWarn sig_ns is_abs_bind ids
| not is_abs_bind = return ()
| otherwise = mapM_ (localSigWarnId sig_ns) ids
localSigWarnId :: NameSet -> Id -> TcM ()
-- NameSet are the Ids that *have* type signatures
localSigWarnId sig_ns id
| not (isSigmaTy (idType id)) = return ()
| idName id `elemNameSet` sig_ns = return ()
| otherwise = warnMissingSig msg id
where
msg = ptext (sLit "Polymorphic local binding with no type signature:")
warnMissingSig :: SDoc -> Id -> TcM ()
warnMissingSig msg id
= do { env0 <- tcInitTidyEnv
; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
; addWarnTcM (env1, mk_msg tidy_ty) }
where
mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]
---------------------------------------------
zonkMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (LHsBinds Id)
zonkMonoBinds env sig_warn binds = mapBagM (zonk_lbind env sig_warn) binds
zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds
zonk_lbind :: ZonkEnv -> SigWarn -> LHsBind TcId -> TcM (LHsBind Id)
zonk_lbind env sig_warn = wrapLocM (zonk_bind env sig_warn)
zonk_lbind :: ZonkEnv -> LHsBind TcId -> TcM (LHsBind Id)
zonk_lbind env = wrapLocM (zonk_bind env)
zonk_bind :: ZonkEnv -> SigWarn -> HsBind TcId -> TcM (HsBind Id)
zonk_bind env sig_warn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
= do { (_env, new_pat) <- zonkPat env pat -- Env already extended
; sig_warn False (collectPatBinders new_pat)
; new_grhss <- zonkGRHSs env zonkLExpr grhss
; new_ty <- zonkTcTypeToType env ty
; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }
zonk_bind env sig_warn (VarBind { var_id = var, var_rhs = expr, var_inline = inl })
zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl })
= do { new_var <- zonkIdBndr env var
; sig_warn False [new_var]
; new_expr <- zonkLExpr env expr
; return (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) }
zonk_bind env sig_warn bind@(FunBind { fun_id = L loc var, fun_matches = ms
, fun_co_fn = co_fn })
zonk_bind env bind@(FunBind { fun_id = L loc var, fun_matches = ms
, fun_co_fn = co_fn })
= do { new_var <- zonkIdBndr env var
; sig_warn False [new_var]
; (env1, new_co_fn) <- zonkCoFn env co_fn
; new_ms <- zonkMatchGroup env1 zonkLExpr ms
; return (bind { fun_id = L loc new_var, fun_matches = new_ms
, fun_co_fn = new_co_fn }) }
zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
, abs_ev_binds = ev_binds
, abs_exports = exports
, abs_binds = val_binds })
zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
, abs_ev_binds = ev_binds
, abs_exports = exports
, abs_binds = val_binds })
= ASSERT( all isImmutableTyVar tyvars )
do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
; (env1, new_evs) <- zonkEvBndrsX env0 evs
; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
do { let env3 = extendIdZonkEnv env2 (collectHsBindsBinders new_val_binds)
; new_val_binds <- zonkMonoBinds env3 noSigWarn val_binds
; new_val_binds <- zonkMonoBinds env3 val_binds
; new_exports <- mapM (zonkExport env3) exports
; return (new_val_binds, new_exports) }
; sig_warn True (map abe_poly new_exports)
; return (AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs
, abs_ev_binds = new_ev_binds
, abs_exports = new_exports, abs_binds = new_val_bind }) }
......@@ -487,13 +406,13 @@ zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
, abe_mono = zonkIdOcc env mono_id
, abe_prags = new_prags })
zonk_bind env _sig_warn (PatSynBind bind@(PSB { psb_id = L loc id
, psb_args = details
, psb_def = lpat
, psb_dir = dir }))
zonk_bind env (PatSynBind bind@(PSB { psb_id = L loc id
, psb_args = details
, psb_def = lpat
, psb_dir = dir }))
= do { id' <- zonkIdBndr env id
; details' <- zonkPatSynDetails env details
;(env1, lpat') <- zonkPat env lpat
; (env1, lpat') <- zonkPat env lpat
; (_env2, dir') <- zonkPatSynDir env1 dir
; return $ PatSynBind $
bind { psb_id = L loc id'
......
......@@ -329,7 +329,7 @@ tcRnModuleTcRnM hsc_env hsc_src
tcRnHsBootDecls hsc_src local_decls
else
{-# SCC "tcRnSrcDecls" #-}
tcRnSrcDecls explicit_mod_hdr export_ies local_decls ;
tcRnSrcDecls explicit_mod_hdr local_decls ;
setGblEnv tcg_env $ do {
-- Process the export list
......@@ -464,12 +464,11 @@ tcRnImports hsc_env import_decls
-}
tcRnSrcDecls :: Bool -- False => no 'module M(..) where' header at all
-> Maybe (Located [LIE RdrName]) -- Exports
-> [LHsDecl RdrName] -- Declarations
-> TcM TcGblEnv
-- Returns the variables free in the decls
-- Reason: solely to report unused imports and bindings
tcRnSrcDecls explicit_mod_hdr exports decls
tcRnSrcDecls explicit_mod_hdr decls
= do { -- Create a binding for $trModule
-- Do this before processing any data type declarations,
-- which need tcg_tr_module to be initialised
......@@ -523,7 +522,6 @@ tcRnSrcDecls explicit_mod_hdr exports decls
-- This pass also warns about missing type signatures
; let { TcGblEnv { tcg_type_env = type_env,
tcg_binds = binds,
tcg_sigs = sig_ns,
tcg_ev_binds = cur_ev_binds,
tcg_imp_specs = imp_specs,
tcg_rules = rules,
......@@ -533,7 +531,7 @@ tcRnSrcDecls explicit_mod_hdr exports decls
; (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects')
<- {-# SCC "zonkTopDecls" #-}
zonkTopDecls all_ev_binds binds exports sig_ns rules vects
zonkTopDecls all_ev_binds binds rules vects
imp_specs fords ;
; traceTc "Tc11" empty
......@@ -2115,7 +2113,7 @@ tcRnDeclsi :: HscEnv
-> IO (Messages, Maybe TcGblEnv)
tcRnDeclsi hsc_env local_decls
= runTcInteractive hsc_env $
tcRnSrcDecls False Nothing local_decls
tcRnSrcDecls False local_decls
externaliseAndTidyId :: Module -> Id -> TcM Id
externaliseAndTidyId this_mod id
......
{-# OPTIONS_GHC -fwarn-missing-exported-sigs #-}
module Bug (Data.List.intercalate, x) where
import qualified Data.List
intercalate = True
x :: Bool
x = intercalate
......@@ -4,6 +4,7 @@ test('T9178', extra_clean(['T9178.o', 'T9178DataType.o',
'T9178.hi', 'T9178DataType.hi']),
multimod_compile, ['T9178', '-Wall'])
test('T9230', normal, compile_without_flag('-fno-warn-tabs'), [''])
test('T10908', normal, compile, [''])
test('T11077', normal, compile, ['-fwarn-missing-exported-sigs'])
test('T11128', normal, compile, [''])
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment