X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=60f0fe93dd478964e7ab803a76701454aef147dc;hb=d93785d99261a433075dcbac8c388730a4dec64f;hp=2200619e2c2e205bea05484d8b1866f50a935c34;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 2200619..60f0fe9 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -364,7 +364,10 @@ tcRnSrcDecls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv -- Reason: solely to report unused imports and bindings tcRnSrcDecls boot_iface decls = do { -- Do all the declarations - (tc_envs, lie) <- getConstraints $ tc_rn_src_decls boot_iface decls ; + (tc_envs, lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ; + ; traceTc "Tc8" empty ; + ; setEnvs tc_envs $ + do { -- Finish simplifying class constraints -- @@ -380,36 +383,38 @@ 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 ; - let { (tcg_env, _) = tc_envs - ; TcGblEnv { tcg_type_env = type_env, - tcg_binds = binds, - tcg_ev_binds = cur_ev_binds, - tcg_rules = rules, - tcg_fords = fords } = tcg_env } ; 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 ; - + -- 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_imp_specs = imp_specs, + tcg_rules = rules, + tcg_fords = fords } = tcg_env + ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ; + + (bind_ids, ev_binds', binds', fords', imp_specs', rules') + <- zonkTopDecls all_ev_binds binds sig_ns rules imp_specs fords ; let { final_type_env = extendTypeEnvWithIds type_env bind_ids ; tcg_env' = tcg_env { tcg_binds = binds', tcg_ev_binds = ev_binds', + tcg_imp_specs = imp_specs', tcg_rules = rules', 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 @@ -477,7 +482,7 @@ tcRnHsBootDecls decls hs_ruleds = rule_decls, hs_annds = _, hs_valds = val_binds }) <- rnTopSrcDecls first_group - ; (gbl_env, lie) <- getConstraints $ setGblEnv tcg_env $ do { + ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do { -- Check for illegal declarations @@ -857,14 +862,14 @@ tcTopSrcDecls boot_details -- Now GHC-generated derived bindings, generics, and selectors -- Do not generate warnings from compiler-generated code; -- hence the use of discardWarnings - (tc_aux_binds, tcl_env) <- discardWarnings (tcTopBinds aux_binds) ; - (tc_deriv_binds, tcl_env) <- setLclTypeEnv tcl_env $ - discardWarnings (tcTopBinds deriv_binds) ; + (tc_aux_binds, specs1, tcl_env) <- discardWarnings (tcTopBinds aux_binds) ; + (tc_deriv_binds, specs2, tcl_env) <- setLclTypeEnv tcl_env $ + discardWarnings (tcTopBinds deriv_binds) ; -- Value declarations next traceTc "Tc5" empty ; - (tc_val_binds, tcl_env) <- setLclTypeEnv tcl_env $ - tcTopBinds val_binds; + (tc_val_binds, specs3, tcl_env) <- setLclTypeEnv tcl_env $ + tcTopBinds val_binds; setLclTypeEnv tcl_env $ do { -- Environment doesn't change now @@ -889,14 +894,19 @@ 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_imp_specs = tcg_imp_specs tcg_env ++ specs1 ++ specs2 ++ specs3 + , 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} @@ -1264,7 +1274,7 @@ tcGhciStmts stmts -- OK, we're ready to typecheck the stmts traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ; - ((tc_stmts, ids), lie) <- getConstraints $ tc_io_stmts stmts $ \ _ -> + ((tc_stmts, ids), lie) <- captureConstraints $ tc_io_stmts stmts $ \ _ -> mapM tcLookupId names ; -- Look up the names right in the middle, -- where they will all be in scope @@ -1297,8 +1307,8 @@ tcRnExpr hsc_env ictxt rdr_expr -- Now typecheck the expression; -- it might have a rank-2 type (e.g. :t runST) - ((_tc_expr, res_ty), lie) <- getConstraints (tcInferRho rn_expr) ; - ((qtvs, dicts, _), lie_top) <- getConstraints (simplifyInfer False {- No MR for now -} + ((_tc_expr, res_ty), lie) <- captureConstraints (tcInferRho rn_expr) ; + ((qtvs, dicts, _), lie_top) <- captureConstraints (simplifyInfer False {- No MR for now -} (tyVarsOfType res_ty) lie) ; _ <- simplifyInteractive lie_top ; -- Ignore the dicionary bindings