import TysWiredIn
import DataCon
import Name
+import NameSet
import Var
import VarSet
import VarEnv
import BasicTypes
import Maybes
import SrcLoc
+import DynFlags( DynFlag(..) )
import Bag
+import FastString
import Outputable
\end{code}
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
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 ->
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
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
--
-- * 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',
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
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}
projects / ghc-hetmet.git / commitdiff