X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=773f307053344ef19f2aa8a070867c3f1c72b02f;hp=2200619e2c2e205bea05484d8b1866f50a935c34;hb=6ea06bbf08517d9805feb82df65cc56ecbaf23a4;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516 diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 2200619..773f307 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -290,7 +290,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) setEnvs tc_envs $ do { - rn_decls <- checkNoErrs $ rnTyClDecls ldecls ; + (rn_decls, _fvs) <- checkNoErrs $ rnTyClDecls [ldecls] ; -- Dump trace of renaming part rnDump (ppr rn_decls) ; @@ -348,7 +348,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mkFakeGroup :: [LTyClDecl a] -> HsGroup a mkFakeGroup decls -- Rather clumsy; lots of unused fields - = emptyRdrGroup { hs_tyclds = decls } + = emptyRdrGroup { hs_tyclds = [decls] } \end{code} @@ -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 @@ -499,7 +504,7 @@ tcRnHsBootDecls decls -- Family instance declarations are rejected here ; traceTc "Tc3" empty ; (tcg_env, inst_infos, _deriv_binds) - <- tcInstDecls1 tycl_decls inst_decls deriv_decls + <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls ; setGblEnv tcg_env $ do { -- Typecheck value declarations @@ -841,7 +846,7 @@ tcTopSrcDecls boot_details -- and import the supporting declarations traceTc "Tc3" empty ; (tcg_env, inst_infos, deriv_binds) - <- tcInstDecls1 tycl_decls inst_decls deriv_decls; + <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls; setGblEnv tcg_env $ do { -- Foreign import declarations next. @@ -857,20 +862,20 @@ 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 -- Second pass over class and instance declarations, traceTc "Tc6" empty ; - inst_binds <- tcInstDecls2 tycl_decls inst_infos ; + inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ; -- Foreign exports traceTc "Tc7" empty ; @@ -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} @@ -1072,7 +1082,8 @@ tcRnStmt hsc_env ictxt rdr_stmt setInteractiveContext hsc_env ictxt $ do { -- Rename; use CmdLineMode because tcRnStmt is only used interactively - (([rn_stmt], _), fvs) <- rnStmts GhciStmt [rdr_stmt] (return ((), emptyFVs)) ; + (([rn_stmt], _), fvs) <- rnStmts GhciStmt [rdr_stmt] $ \_ -> + return ((), emptyFVs) ; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ; failIfErrsM ; rnDump (ppr rn_stmt) ; @@ -1264,7 +1275,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 +1308,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