X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcHsSyn.lhs;h=7c12410556a83ad32c544e213a571de346213522;hb=25bff7fe1a22edbafa188af8d844c67057fa5eb8;hp=074ab39537e08f7fe739965ac54fdf946277699b;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 074ab39..7c12410 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,29 +268,53 @@ 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] -> [LTcSpecPrag] -> [LForeignDecl TcId] -> TcM ([Id], Bag EvBind, Bag (LHsBind Id), [LForeignDecl Id], + [LTcSpecPrag], [LRuleDecl Id]) -zonkTopDecls ev_binds binds rules fords +zonkTopDecls ev_binds binds sig_ns rules imp_specs 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 + ; specs' <- zonkLTcSpecPrags env2 imp_specs ; fords' <- zonkForeignExports env2 fords - ; return (zonkEnvIds env2, ev_binds', binds', fords', rules') } + ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') } --------------------------------------------- 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 +329,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 ] -zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id) -zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = 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 -> 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 @@ -369,12 +432,16 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs, abs_ev_binds = ev zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags zonkSpecPrags _ IsDefaultMethod = return IsDefaultMethod -zonkSpecPrags env (SpecPrags ps) = do { ps' <- mapM zonk_prag ps +zonkSpecPrags env (SpecPrags ps) = do { ps' <- zonkLTcSpecPrags env ps ; return (SpecPrags ps') } + +zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag] +zonkLTcSpecPrags env ps + = mapM zonk_prag ps where - zonk_prag (L loc (SpecPrag co_fn inl)) + zonk_prag (L loc (SpecPrag id co_fn inl)) = do { (_, co_fn') <- zonkCoFn env co_fn - ; return (L loc (SpecPrag co_fn' inl)) } + ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) } \end{code} %************************************************************************ @@ -1009,7 +1076,7 @@ zonkEvBind env (EvBind var term) %************************************************************************ %* * -\subsection[BackSubst-Foreign]{Foreign exports} + Zonking types %* * %************************************************************************