X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcHsSyn.lhs;h=4f2eda72616979537ccba7e135dcf99249e77d27;hp=074ab39537e08f7fe739965ac54fdf946277699b;hb=34c8d0312071f7d0f4d221a997d3408c653ef9e5;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516 diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 074ab39..4f2eda7 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} @@ -79,7 +82,6 @@ hsPatType :: Pat Id -> Type hsPatType (ParPat pat) = hsLPatType pat hsPatType (WildPat ty) = ty hsPatType (VarPat var) = idType var -hsPatType (VarPatOut var _) = idType var hsPatType (BangPat pat) = hsLPatType pat hsPatType (LazyPat pat) = hsLPatType pat hsPatType (LitPat lit) = hsLitType lit @@ -265,29 +267,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 +328,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 @@ -369,12 +431,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} %************************************************************************ @@ -476,6 +542,22 @@ zonkExpr env (HsPar e) = zonkLExpr env e `thenM` \new_e -> returnM (HsPar new_e) +zonkExpr env (HsHetMetBrak c e) + = do c' <- zonkTcTypeToType env c + e' <- zonkLExpr env e + return (HsHetMetBrak c' e') + +zonkExpr env (HsHetMetEsc c t e) + = do c' <- zonkTcTypeToType env c + t' <- zonkTcTypeToType env t + e' <- zonkLExpr env e + return (HsHetMetEsc c' t' e') + +zonkExpr env (HsHetMetCSP c e) + = do c' <- zonkTcTypeToType env c + e' <- zonkLExpr env e + return (HsHetMetCSP c' e') + zonkExpr env (SectionL expr op) = zonkLExpr env expr `thenM` \ new_expr -> zonkLExpr env op `thenM` \ new_op -> @@ -498,11 +580,12 @@ zonkExpr env (HsCase expr ms) zonkMatchGroup env ms `thenM` \ new_ms -> returnM (HsCase new_expr new_ms) -zonkExpr env (HsIf e1 e2 e3) - = zonkLExpr env e1 `thenM` \ new_e1 -> - zonkLExpr env e2 `thenM` \ new_e2 -> - zonkLExpr env e3 `thenM` \ new_e3 -> - returnM (HsIf new_e1 new_e2 new_e3) +zonkExpr env (HsIf e0 e1 e2 e3) + = do { new_e0 <- fmapMaybeM (zonkExpr env) e0 + ; new_e1 <- zonkLExpr env e1 + ; new_e2 <- zonkLExpr env e2 + ; new_e3 <- zonkLExpr env e3 + ; returnM (HsIf new_e0 new_e1 new_e2 new_e3) } zonkExpr env (HsLet binds expr) = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) -> @@ -513,8 +596,7 @@ zonkExpr env (HsDo do_or_lc stmts body ty) = zonkStmts env stmts `thenM` \ (new_env, new_stmts) -> zonkLExpr new_env body `thenM` \ new_body -> zonkTcTypeToType env ty `thenM` \ new_ty -> - zonkDo env do_or_lc `thenM` \ new_do_or_lc -> - returnM (HsDo new_do_or_lc new_stmts new_body new_ty) + returnM (HsDo do_or_lc new_stmts new_body new_ty) zonkExpr env (ExplicitList ty exprs) = zonkTcTypeToType env ty `thenM` \ new_ty -> @@ -622,13 +704,6 @@ zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs ; return (env1, WpLet bs') } ------------------------------------------------------------------------- -zonkDo :: ZonkEnv -> HsStmtContext Name -> TcM (HsStmtContext Name) --- Only used for 'do', so the only Ids are in a MDoExpr table -zonkDo env (MDoExpr tbl) = do { tbl' <- mapSndM (zonkExpr env) tbl - ; return (MDoExpr tbl') } -zonkDo _ do_or_lc = return do_or_lc - -------------------------------------------------------------------------- zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id) zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty }) = do { ty' <- zonkTcTypeToType env ty @@ -680,7 +755,7 @@ zonkStmt env (ParStmt stmts_w_bndrs) zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id - , recS_rec_rets = rets, recS_dicts = binds }) + , recS_rec_rets = rets }) = do { new_rvs <- zonkIdBndrs env rvs ; new_lvs <- zonkIdBndrs env lvs ; new_ret_id <- zonkExpr env ret_id @@ -691,13 +766,11 @@ zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_id -- Zonk the ret-expressions in an envt that -- has the polymorphic bindings in the envt ; new_rets <- mapM (zonkExpr env2) rets - ; let env3 = extendZonkEnv env new_lvs -- Only the lvs are needed - ; (env4, new_binds) <- zonkTcEvBinds env3 binds - ; return (env4, + ; return (extendZonkEnv env new_lvs, -- Only the lvs are needed RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id - , recS_rec_rets = new_rets, recS_dicts = new_binds }) } + , recS_rec_rets = new_rets }) } zonkStmt env (ExprStmt expr then_op ty) = zonkLExpr env expr `thenM` \ new_expr -> @@ -784,11 +857,6 @@ zonk_pat env (VarPat v) = do { v' <- zonkIdBndr env v ; return (extendZonkEnv1 env v', VarPat v') } -zonk_pat env (VarPatOut v binds) - = do { v' <- zonkIdBndr env v - ; (env', binds') <- zonkTcEvBinds (extendZonkEnv1 env v') binds - ; returnM (env', VarPatOut v' binds') } - zonk_pat env (LazyPat pat) = do { (env', pat') <- zonkPat env pat ; return (env', LazyPat pat') } @@ -841,10 +909,7 @@ zonk_pat env (SigPatOut pat ty) zonk_pat env (NPat lit mb_neg eq_expr) = do { lit' <- zonkOverLit env lit - ; mb_neg' <- case mb_neg of - Nothing -> return Nothing - Just neg -> do { neg' <- zonkExpr env neg - ; return (Just neg') } + ; mb_neg' <- fmapMaybeM (zonkExpr env) mb_neg ; eq_expr' <- zonkExpr env eq_expr ; return (env, NPat lit' mb_neg' eq_expr') } @@ -974,7 +1039,7 @@ zonkEvTerm env (EvCast v co) = ASSERT( isId v) do { co' <- zonkTcTypeToType env co ; return (EvCast (zonkIdOcc env v) co') } zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n) -zonkEvTerm env (EvDFunApp df tys tms) +zonkEvTerm env (EvDFunApp df tys tms) = do { tys' <- zonkTcTypeToTypes env tys ; let tms' = map (zonkEvVarOcc env) tms ; return (EvDFunApp (zonkIdOcc env df) tys' tms') } @@ -1009,7 +1074,7 @@ zonkEvBind env (EvBind var term) %************************************************************************ %* * -\subsection[BackSubst-Foreign]{Foreign exports} + Zonking types %* * %************************************************************************ @@ -1026,7 +1091,7 @@ zonkTypeCollecting unbound_tv_set = zonkType (mkZonkTcTyVar zonk_unbound_tyvar) where zonk_unbound_tyvar tv - = do { tv' <- zonkQuantifiedTyVar tv + = do { tv' <- zonkQuantifiedTyVar tv ; tv_set <- readMutVar unbound_tv_set ; writeMutVar unbound_tv_set (extendVarSet tv_set tv') ; return (mkTyVarTy tv') }