From e8fa04cf0d656c4a2ff737278b8cea9fce3b5a2b Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Sun, 19 Sep 2010 15:33:27 +0000 Subject: [PATCH] Add a flag -fwarn-missing-local-sigs, and improve -fwarn-mising-signatures The new flag prints out a warning if you have a local, polymorphic binding that lacks a type signature. It's meant to help with the transition to the new typechecker, which discourages local let-generalisation. At the same time I moved the missing-signature code to TcHsSyn, where it takes place as part of zonking. That way the types are reported after all typechecking is complete, thereby fixing Trac #3696. (It's even more important for local bindings, which is why I made the change.) --- compiler/hsSyn/HsBinds.lhs | 7 ++ compiler/main/DynFlags.hs | 2 + compiler/typecheck/TcBinds.lhs | 39 ---------- compiler/typecheck/TcHsSyn.lhs | 147 ++++++++++++++++++++++++++----------- compiler/typecheck/TcRnDriver.lhs | 45 +++++++----- compiler/typecheck/TcRnMonad.lhs | 1 + compiler/typecheck/TcRnTypes.lhs | 1 + 7 files changed, 141 insertions(+), 101 deletions(-) diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 0615cbe..15fd419 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -245,6 +245,13 @@ plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2) = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2) plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2) = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2) + +getTypeSigNames :: HsValBinds a -> NameSet +-- Get the names that have a user type sig +getTypeSigNames (ValBindsIn {}) + = panic "getTypeSigNames" +getTypeSigNames (ValBindsOut _ sigs) + = mkNameSet [unLoc n | L _ (TypeSig n _) <- sigs] \end{code} What AbsBinds means diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index b90753b..6818793 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -189,6 +189,7 @@ data DynFlag | Opt_WarnMissingImportList | Opt_WarnMissingMethods | Opt_WarnMissingSigs + | Opt_WarnMissingLocalSigs | Opt_WarnNameShadowing | Opt_WarnOverlappingPatterns | Opt_WarnSimplePatterns @@ -1428,6 +1429,7 @@ fFlags = [ ( "warn-missing-import-lists", Opt_WarnMissingImportList, nop ), ( "warn-missing-methods", Opt_WarnMissingMethods, nop ), ( "warn-missing-signatures", Opt_WarnMissingSigs, nop ), + ( "warn-missing-local-sigs", Opt_WarnMissingLocalSigs, nop ), ( "warn-name-shadowing", Opt_WarnNameShadowing, nop ), ( "warn-overlapping-patterns", Opt_WarnOverlappingPatterns, nop ), ( "warn-simple-patterns", Opt_WarnSimplePatterns, nop ), diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 5d966f9..abd04a6 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -335,16 +335,8 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list -- They desugar to a case expression in the end ; checkStrictBinds top_lvl rec_group bind_list poly_ids - -- Warn about missing signatures - -- Do this only when we we have a type to offer - ; warn_missing_sigs <- doptM Opt_WarnMissingSigs - ; when (isTopLevel top_lvl && warn_missing_sigs) $ - mapM_ missingSigWarn (filter no_sig poly_ids) - ; return (binds, poly_ids) } where - no_sig id = isNothing (sig_fn (idName id)) - binder_names = collectHsBindListBinders bind_list loc = getLoc (head bind_list) -- TODO: location a bit awkward, but the mbinds have been @@ -1191,35 +1183,4 @@ sigContextsCtxt sig1 sig2 where id1 = sig_id sig1 id2 = sig_id sig2 - ------------------------------------------------ -{- -badStrictSig :: Bool -> TcSigInfo -> SDoc -badStrictSig unlifted sig - = hang (ptext (sLit "Illegal polymorphic signature in") <+> msg) - 2 (ppr sig) - where - msg | unlifted = ptext (sLit "an unlifted binding") - | otherwise = ptext (sLit "a bang-pattern binding") - -restrictedBindSigErr :: [Name] -> SDoc -restrictedBindSigErr binder_names - = hang (ptext (sLit "Illegal type signature(s)")) - 2 (vcat [ptext (sLit "in a binding group for") <+> pprBinders binder_names, - ptext (sLit "that falls under the monomorphism restriction")]) - -genCtxt :: [Name] -> SDoc -genCtxt binder_names - = ptext (sLit "When generalising the type(s) for") <+> pprBinders binder_names --} - -missingSigWarn :: TcId -> TcM () -missingSigWarn id - = do { env0 <- tcInitTidyEnv - ; let (env1, tidy_ty) = tidyOpenType env0 (idType id) - ; addWarnTcM (env1, mk_msg tidy_ty) } - where - name = idName id - mk_msg ty = vcat [ptext (sLit "Definition but no type signature for") <+> quotes (ppr name), - sep [ptext (sLit "Inferred type:") <+> pprHsVar name <+> dcolon <+> ppr ty]] \end{code} diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 074ab39..46b8c04 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -39,6 +39,7 @@ import TysPrim import TysWiredIn import DataCon import Name +import NameSet import Var import VarSet import VarEnv @@ -46,7 +47,9 @@ import Literal import BasicTypes import Maybes import SrcLoc +import DynFlags( DynFlag(..) ) import Bag +import FastString import Outputable \end{code} @@ -265,16 +268,24 @@ zonkTopExpr e = zonkExpr emptyZonkEnv e zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id) zonkTopLExpr e = zonkLExpr emptyZonkEnv e -zonkTopDecls :: Bag EvBind -> LHsBinds TcId -> [LRuleDecl TcId] -> [LForeignDecl TcId] +zonkTopDecls :: Bag EvBind + -> LHsBinds TcId -> NameSet + -> [LRuleDecl TcId] -> [LForeignDecl TcId] -> TcM ([Id], Bag EvBind, Bag (LHsBind Id), [LForeignDecl Id], [LRuleDecl Id]) -zonkTopDecls ev_binds binds rules fords +zonkTopDecls ev_binds binds sig_ns rules fords = do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds - ; (env2, binds') <- zonkRecMonoBinds env1 binds + -- Warn about missing signatures + -- Do this only when we we have a type to offer + ; warn_missing_sigs <- doptM Opt_WarnMissingSigs + ; let sig_warn | warn_missing_sigs = topSigWarn sig_ns + | otherwise = noSigWarn + + ; (env2, binds') <- zonkRecMonoBinds env1 sig_warn binds -- Top level is implicitly recursive ; rules' <- zonkRules env2 rules ; fords' <- zonkForeignExports env2 fords @@ -285,9 +296,23 @@ zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id) zonkLocalBinds env EmptyLocalBinds = return (env, EmptyLocalBinds) -zonkLocalBinds env (HsValBinds binds) - = do { (env1, new_binds) <- zonkValBinds env binds - ; return (env1, HsValBinds new_binds) } +zonkLocalBinds _ (HsValBinds (ValBindsIn {})) + = panic "zonkLocalBinds" -- Not in typechecker output + +zonkLocalBinds env (HsValBinds vb@(ValBindsOut binds sigs)) + = do { warn_missing_sigs <- doptM 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 + ; return (env1, HsValBinds (ValBindsOut new_binds sigs)) } + where + 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 + ; return (env2, (r,b'):bs') } zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = mappM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds -> @@ -302,62 +327,98 @@ zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) zonkLExpr env e `thenM` \ e' -> returnM (IPBind n' e') - ---------------------------------------------- -zonkValBinds :: ZonkEnv -> HsValBinds TcId -> TcM (ZonkEnv, HsValBinds Id) -zonkValBinds _ (ValBindsIn _ _) - = panic "zonkValBinds" -- Not in typechecker output -zonkValBinds env (ValBindsOut binds sigs) - = do { (env1, new_binds) <- go env binds - ; return (env1, ValBindsOut new_binds sigs) } - where - go env [] = return (env, []) - go env ((r,b):bs) = do { (env1, b') <- zonkRecMonoBinds env b - ; (env2, bs') <- go env1 bs - ; return (env2, (r,b'):bs') } - --------------------------------------------- -zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id) -zonkRecMonoBinds env binds +zonkRecMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id) +zonkRecMonoBinds env sig_warn binds = fixM (\ ~(_, new_binds) -> do { let env1 = extendZonkEnv env (collectHsBindsBinders new_binds) - ; binds' <- zonkMonoBinds env1 binds + ; binds' <- zonkMonoBinds env1 sig_warn binds ; return (env1, binds') }) --------------------------------------------- -zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id) -zonkMonoBinds env binds = mapBagM (wrapLocM (zonk_bind env)) binds +type SigWarn = Bool -> [Id] -> TcM () + -- Missing-signature warning + -- The Bool is True for an AbsBinds, False otherwise + +noSigWarn :: SigWarn +noSigWarn _ _ = 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 "Polymophic 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 $ pprHsVar (idName id) <+> dcolon <+> ppr ty ] + +--------------------------------------------- +zonkMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (LHsBinds Id) +zonkMonoBinds env sig_warn binds = mapBagM (wrapLocM (zonk_bind env sig_warn)) binds -zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id) -zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty}) +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}) = do { (_env, new_pat) <- zonkPat env pat -- Env already extended + ; sig_warn False (collectPatBinders new_pat) ; new_grhss <- zonkGRHSs env grhss ; new_ty <- zonkTcTypeToType env ty ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) } -zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl }) - = zonkIdBndr env var `thenM` \ new_var -> - zonkLExpr env expr `thenM` \ new_expr -> - returnM (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) - -zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms - , fun_co_fn = co_fn }) - = wrapLocM (zonkIdBndr env) var `thenM` \ new_var -> - zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) -> - zonkMatchGroup env1 ms `thenM` \ new_ms -> - returnM (bind { fun_id = new_var, fun_matches = new_ms - , fun_co_fn = new_co_fn }) - -zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs, abs_ev_binds = ev_binds, - abs_exports = exports, abs_binds = val_binds }) +zonk_bind env sig_warn (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 }) + = do { new_var <- zonkIdBndr env var + ; sig_warn False [new_var] + ; (env1, new_co_fn) <- zonkCoFn env co_fn + ; new_ms <- zonkMatchGroup env1 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 }) = ASSERT( all isImmutableTyVar tyvars ) do { (env1, new_evs) <- zonkEvBndrsX env evs ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) -> do { let env3 = extendZonkEnv env2 (collectHsBindsBinders new_val_binds) - ; new_val_binds <- zonkMonoBinds env3 val_binds + ; new_val_binds <- zonkMonoBinds env3 noSigWarn val_binds ; new_exports <- mapM (zonkExport env3) exports ; return (new_val_binds, new_exports) } + ; sig_warn True [b | (_,b,_,_) <- new_exports] ; return (AbsBinds { abs_tvs = tyvars, abs_ev_vars = new_evs, abs_ev_binds = new_ev_binds , abs_exports = new_exports, abs_binds = new_val_bind }) } where diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 2200619..a42e85d 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -365,6 +365,9 @@ tcRnSrcDecls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv tcRnSrcDecls boot_iface decls = do { -- Do all the declarations (tc_envs, lie) <- getConstraints $ tc_rn_src_decls boot_iface decls ; + ; traceTc "Tc8" empty ; + ; setEnvs tc_envs $ + do { -- Finish simplifying class constraints -- @@ -380,27 +383,27 @@ tcRnSrcDecls boot_iface decls -- * the global env exposes the instances to simplifyTop -- * the local env exposes the local Ids to simplifyTop, -- so that we get better error messages (monomorphism restriction) - traceTc "Tc8" empty ; - new_ev_binds <- setEnvs tc_envs (simplifyTop lie) ; - - -- Backsubstitution. This must be done last. - -- Even simplifyTop may do some unification. + new_ev_binds <- simplifyTop lie ; traceTc "Tc9" empty ; + + failIfErrsM ; -- Don't zonk if there have been errors + -- It's a waste of time; and we may get debug warnings + -- about strangely-typed TyCons! + + -- Zonk the final code. This must be done last. + -- Even simplifyTop may do some unification. + -- This pass also warns about missing type signatures let { (tcg_env, _) = tc_envs ; TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, + tcg_sigs = sig_ns, tcg_ev_binds = cur_ev_binds, tcg_rules = rules, - tcg_fords = fords } = tcg_env } ; + tcg_fords = fords } = tcg_env + ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ; - failIfErrsM ; -- Don't zonk if there have been errors - -- It's a waste of time; and we may get debug warnings - -- about strangely-typed TyCons! - - let { all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ; (bind_ids, ev_binds', binds', fords', rules') - <- zonkTopDecls all_ev_binds binds rules fords ; - + <- zonkTopDecls all_ev_binds binds sig_ns rules fords ; let { final_type_env = extendTypeEnvWithIds type_env bind_ids ; tcg_env' = tcg_env { tcg_binds = binds', @@ -409,7 +412,7 @@ tcRnSrcDecls boot_iface decls tcg_fords = fords' } } ; setGlobalTypeEnv tcg_env' final_type_env - } + } } tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) -- Loops around dealing with each top level inter-splice group @@ -889,14 +892,18 @@ tcTopSrcDecls boot_details tc_deriv_binds `unionBags` tc_aux_binds `unionBags` inst_binds `unionBags` - foe_binds; + foe_binds + + ; sig_names = mkNameSet (collectHsValBinders val_binds) + `minusNameSet` getTypeSigNames val_binds -- Extend the GblEnv with the (as yet un-zonked) -- bindings, rules, foreign decls - tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds, - tcg_rules = tcg_rules tcg_env ++ rules, - tcg_anns = tcg_anns tcg_env ++ annotations, - tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ; + ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds + , tcg_sigs = tcg_sigs tcg_env `unionNameSets` sig_names + , tcg_rules = tcg_rules tcg_env ++ rules + , tcg_anns = tcg_anns tcg_env ++ annotations + , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ; return (tcg_env', tcl_env) }}}}}} \end{code} diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 77d7374..b1d963e 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -108,6 +108,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcg_rn_decls = maybe_rn_syntax emptyRnGroup, tcg_binds = emptyLHsBinds, + tcg_sigs = emptyNameSet, tcg_ev_binds = emptyBag, tcg_warns = NoWarnings, tcg_anns = [], diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index ca17355..fce06d1 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -256,6 +256,7 @@ data TcGblEnv tcg_ev_binds :: Bag EvBind, -- Top-level evidence bindings tcg_binds :: LHsBinds Id, -- Value bindings in this module + tcg_sigs :: NameSet, -- ...Top-level names that *lack* a signature tcg_warns :: Warnings, -- ...Warnings and deprecations tcg_anns :: [Annotation], -- ...Annotations tcg_insts :: [Instance], -- ...Instances -- 1.7.10.4