Commit e8fa04cf authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

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.)
parent e4b5abb6
......@@ -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
......
......@@ -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 ),
......
......@@ -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}
......@@ -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
......
......@@ -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}
......
......@@ -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 = [],
......
......@@ -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
......
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