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
projects / ghc-hetmet.git / blobdiff