X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=156b52fbefa2271e9cb6940dc9881bd55cf40691;hb=8b08c15b8ace5a76e341939081fbb6ad2736ddd1;hp=af9a03d2ebff07f845090dcf5781886f19674f72;hpb=f4510d27c5883fe7e8570f4dd49d45a8b0122f2c;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index af9a03d..156b52f 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -12,6 +12,7 @@ module TcRnDriver ( tcRnLookupName, tcRnGetInfo, getModuleExports, + tcRnRecoverDataCon, #endif tcRnModule, tcTopSrcDecls, @@ -69,8 +70,11 @@ import TyCon import SrcLoc import HscTypes import Outputable +import Breakpoints #ifdef GHCI +import Linker +import DataCon import TcHsType import TcMType import TcMatches @@ -173,6 +177,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax loadOrphanModules (imp_orphs imports) False ; loadOrphanModules (imp_finsts imports) True ; + traceRn (text "rn1: checking family instance consistency") ; let { directlyImpMods = map (\(mod, _, _) -> mod) . moduleEnvElts . imp_mods @@ -305,7 +310,8 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mg_fix_env = emptyFixityEnv, mg_deprecs = NoDeprecs, mg_foreign = NoStubs, - mg_hpc_info = noHpcInfo + mg_hpc_info = noHpcInfo, + mg_dbg_sites = noDbgSites } } ; tcCoreDump mod_guts ; @@ -337,15 +343,34 @@ tcRnSrcDecls decls boot_iface <- tcHiBootIface mod ; -- Do all the declarations - tcg_env <- tc_rn_src_decls boot_iface decls ; + (tc_envs, lie) <- getLIE $ tc_rn_src_decls boot_iface decls ; + + -- Finish simplifying class constraints + -- + -- tcSimplifyTop deals with constant or ambiguous InstIds. + -- How could there be ambiguous ones? They can only arise if a + -- top-level decl falls under the monomorphism restriction + -- and no subsequent decl instantiates its type. + -- + -- We do this after checkMain, so that we use the type info + -- thaat checkMain adds + -- + -- We do it with both global and local env in scope: + -- * the global env exposes the instances to tcSimplifyTop + -- * the local env exposes the local Ids to tcSimplifyTop, + -- so that we get better error messages (monomorphism restriction) + traceTc (text "Tc8") ; + inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ; -- Backsubstitution. This must be done last. -- Even tcSimplifyTop may do some unification. traceTc (text "Tc9") ; - let { TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, - tcg_rules = rules, tcg_fords = fords } = tcg_env } ; + let { (tcg_env, _) = tc_envs + ; TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, + tcg_rules = rules, tcg_fords = fords } = tcg_env + ; all_binds = binds `unionBags` inst_binds } ; - (bind_ids, binds', fords', rules') <- zonkTopDecls binds rules fords ; + (bind_ids, binds', fords', rules') <- zonkTopDecls all_binds rules fords ; let { final_type_env = extendTypeEnvWithIds type_env bind_ids ; tcg_env' = tcg_env { tcg_type_env = final_type_env, @@ -362,7 +387,7 @@ tcRnSrcDecls decls return (tcg_env' { tcg_binds = tcg_binds tcg_env' `unionBags` dfun_binds }) } -tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv +tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) -- Loops around dealing with each top level inter-splice group -- in turn, until it's dealt with the entire module tc_rn_src_decls boot_details ds @@ -370,39 +395,27 @@ tc_rn_src_decls boot_details ds -- If ds is [] we get ([], Nothing) -- Deal with decls up to, but not including, the first splice - (tcg_env, rn_decls) <- rnTopSrcDecls first_group ; - ((tcg_env, tcl_env), lie) <- getLIE $ setGblEnv tcg_env $ - tcTopSrcDecls boot_details rn_decls ; - - -- tcSimplifyTop deals with constant or ambiguous InstIds. - -- How could there be ambiguous ones? They can only arise if a - -- top-level decl falls under the monomorphism restriction - -- and no subsequent decl instantiates its type. - traceTc (text "Tc8") ; - inst_binds <- setEnvs (tcg_env, tcl_env) (tcSimplifyTop lie) ; - -- Setting the global env exposes the instances to tcSimplifyTop - -- Setting the local env exposes the local Ids to tcSimplifyTop, - -- so that we get better error messages (monomorphism restriction) - - let { tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` inst_binds } } ; - - setEnvs (tcg_env', tcl_env) $ + (tcg_env, rn_decls) <- checkNoErrs $ rnTopSrcDecls first_group ; + -- checkNoErrs: don't typecheck if renaming failed + tc_envs <- setGblEnv tcg_env $ + tcTopSrcDecls boot_details rn_decls ; -- If there is no splice, we're nearly done + setEnvs tc_envs $ case group_tail of { - Nothing -> -- Last thing: check for `main' - checkMain ; + Nothing -> do { tcg_env <- checkMain ; -- Check for `main' + return (tcg_env, snd tc_envs) + } ; -- If there's a splice, we must carry on - Just (SpliceDecl splice_expr, rest_ds) -> - do { + Just (SpliceDecl splice_expr, rest_ds) -> do { #ifndef GHCI failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler") #else -- Rename the splice expression, and get its supporting decls - (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ; - failIfErrsM ; -- Don't typecheck if renaming failed + (rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ; + -- checkNoErrs: don't typecheck if renaming failed rnDump (ppr rn_splice_expr) ; -- Execute the splice @@ -412,7 +425,7 @@ tc_rn_src_decls boot_details ds setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ tc_rn_src_decls boot_details (spliced_decls ++ rest_ds) #endif /* GHCI */ - }}} + } } } \end{code} %************************************************************************ @@ -1028,12 +1041,11 @@ 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) <- getLIE (tcInferRho rn_expr) ; - ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ; + ((qtvs, dict_insts, _), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ; tcSimplifyInteractive lie_top ; - qtvs' <- mappM zonkQuantifiedTyVar qtvs ; - let { all_expr_ty = mkForAllTys qtvs' $ - mkFunTys (map idType dict_ids) $ + let { all_expr_ty = mkForAllTys qtvs $ + mkFunTys (map (idType . instToId) dict_insts) $ res_ty } ; zonkTcType all_expr_ty } @@ -1129,6 +1141,12 @@ lookup_rdr_name rdr_name = do { return good_names } +tcRnRecoverDataCon :: HscEnv -> a -> IO (Maybe DataCon) +tcRnRecoverDataCon hsc_env a + = initTcPrintErrors hsc_env iNTERACTIVE $ + setInteractiveContext hsc_env (hsc_IC hsc_env) $ + do name <- recoverDataCon a + tcLookupDataCon name tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing) tcRnLookupName hsc_env name @@ -1164,7 +1182,6 @@ tcRnGetInfo hsc_env name ispecs <- lookupInsts (icPrintUnqual ictxt) thing return (thing, fixity, ispecs) - lookupInsts :: PrintUnqualified -> TyThing -> TcM [Instance] -- Filter the instances by the ones whose tycons (or clases resp) -- are in scope unqualified. Otherwise we list a whole lot too many!