X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=35f48d0db0c2bdc645ce788f9c866be6f656c753;hb=ebec49fed627b7dd17e297ddc79a9c677a2ce538;hp=2afe8900513d8de36363abdfade72590d620e171;hpb=bb7db74ea39eddce8f7502717bd9a043bc95e9f8;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 2afe890..35f48d0 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -82,6 +82,7 @@ import Outputable import DataCon import Type import Class +import Data.List ( sortBy ) #ifdef GHCI import Linker @@ -167,9 +168,9 @@ tcRnModule hsc_env hsc_src save_rn_syntax -- thing (especially via 'module Foo' export item) -- That is, only uses in the *body* of the module are complained about traceRn (text "rn3") ; - failIfErrsM ; -- finishDeprecations crashes sometimes + failIfErrsM ; -- finishWarnings crashes sometimes -- as a result of typechecker repairs (e.g. unboundNames) - tcg_env <- finishDeprecations (hsc_dflags hsc_env) mod_deprec tcg_env ; + tcg_env <- finishWarnings (hsc_dflags hsc_env) mod_deprec tcg_env ; -- Process the export list traceRn (text "rn4a: before exports"); @@ -180,10 +181,11 @@ tcRnModule hsc_env hsc_src save_rn_syntax -- Must be done after processing the exports tcg_env <- checkHiBootIface tcg_env boot_iface ; - -- Make the new type env available to stuff slurped from interface files - -- Must do this after checkHiBootIface, because the latter might add new - -- bindings for boot_dfuns, which may be mentioned in imported unfoldings - writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ; + -- The new type env is already available to stuff slurped from + -- interface files, via TcEnv.updateGlobalTypeEnv + -- It's important that this includes the stuff in checkHiBootIface, + -- because the latter might add new bindings for boot_dfuns, + -- which may be mentioned in imported unfoldings -- Rename the Haddock documentation tcg_env <- rnHaddock module_info maybe_doc tcg_env ; @@ -337,7 +339,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- Stubs mg_rdr_env = emptyGlobalRdrEnv, mg_fix_env = emptyFixityEnv, - mg_deprecs = NoDeprecs, + mg_warns = NoWarnings, mg_foreign = NoStubs, mg_hpc_info = emptyHpcInfo False, mg_modBreaks = emptyModBreaks, @@ -399,13 +401,13 @@ tcRnSrcDecls boot_iface decls (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, - tcg_binds = binds', + ; tcg_env' = tcg_env { tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' } } ; - return (tcg_env' { tcg_binds = tcg_binds tcg_env' }) + setGlobalTypeEnv tcg_env' final_type_env } tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) @@ -500,7 +502,7 @@ tcRnHsBootDecls decls ; type_env1 = extendTypeEnvWithIds type_env0 val_ids ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids ; dfun_ids = map iDFunId inst_infos } - ; return (gbl_env { tcg_type_env = type_env2 }) + ; setGlobalTypeEnv gbl_env type_env2 }}}} spliceInHsBootErr (SpliceDecl (L loc _), _) @@ -536,15 +538,6 @@ checkHiBootIface -- Check the exports of the boot module, one by one ; mapM_ check_export boot_exports - -- Check instance declarations - ; mb_dfun_prs <- mapM check_inst boot_insts - ; let tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds, - tcg_type_env = extendTypeEnvWithIds local_type_env boot_dfuns } - dfun_prs = catMaybes mb_dfun_prs - boot_dfuns = map fst dfun_prs - dfun_binds = listToBag [ noLoc $ VarBind boot_dfun (nlHsVar dfun) - | (boot_dfun, dfun) <- dfun_prs ] - -- Check for no family instances ; unless (null boot_fam_insts) $ panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++ @@ -553,8 +546,17 @@ checkHiBootIface -- be the equivalent to the dfun bindings returned for class -- instances? We can't easily equate tycons... + -- Check instance declarations + ; mb_dfun_prs <- mapM check_inst boot_insts + ; let tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds } + final_type_env = extendTypeEnvWithIds local_type_env boot_dfuns + dfun_prs = catMaybes mb_dfun_prs + boot_dfuns = map fst dfun_prs + dfun_binds = listToBag [ noLoc $ VarBind boot_dfun (nlHsVar dfun) + | (boot_dfun, dfun) <- dfun_prs ] + ; failIfErrsM - ; return tcg_env' } + ; setGlobalTypeEnv tcg_env' final_type_env } where check_export boot_avail -- boot_avail is exported by the boot iface | name `elem` dfun_names = return () @@ -778,10 +780,6 @@ tcTopSrcDecls boot_details tcg_env <- tcTyAndClassDecls boot_details tycl_decls ; -- If there are any errors, tcTyAndClassDecls fails here - -- Make these type and class decls available to stuff slurped from interface files - writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ; - - setGblEnv tcg_env $ do { -- Source-language instances, including derivings, -- and import the supporting declarations @@ -906,11 +904,7 @@ check_main dflags tcg_env where mod = tcg_mod tcg_env main_mod = mainModIs dflags - main_is_flag = mainFunIs dflags - - main_fn = case main_is_flag of - Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) - Nothing -> main_RDR_Unqual + main_fn = getMainFun dflags complain_no_main | ghcLink dflags == LinkInMemory = return () | otherwise = failWithTc noMainMsg @@ -921,8 +915,9 @@ check_main dflags tcg_env mainCtxt = ptext (sLit "When checking the type of the") <+> pp_main_fn noMainMsg = ptext (sLit "The") <+> pp_main_fn <+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod) - pp_main_fn | isJust main_is_flag = ptext (sLit "main function") <+> quotes (ppr main_fn) - | otherwise = ptext (sLit "function") <+> quotes (ppr main_fn) + pp_main_fn | main_fn == main_RDR_Unqual = ptext (sLit "function") <+> quotes (ppr main_fn) + | otherwise = ptext (sLit "main function") <+> quotes (ppr main_fn) + \end{code} Note [Root-main Id] @@ -979,7 +974,7 @@ setInteractiveContext hsc_env icxt thing_inside tcRnStmt :: HscEnv -> InteractiveContext -> LStmt RdrName - -> IO (Maybe ([Id], LHsExpr Id)) + -> IO (Messages, Maybe ([Id], LHsExpr Id)) -- The returned [Id] is the list of new Ids bound by -- this statement. It can be used to extend the -- InteractiveContext via extendInteractiveContext. @@ -1212,7 +1207,7 @@ tcRnExpr just finds the type of an expression tcRnExpr :: HscEnv -> InteractiveContext -> LHsExpr RdrName - -> IO (Maybe Type) + -> IO (Messages, Maybe Type) tcRnExpr hsc_env ictxt rdr_expr = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do { @@ -1241,7 +1236,7 @@ tcRnType just finds the kind of a type tcRnType :: HscEnv -> InteractiveContext -> LHsType RdrName - -> IO (Maybe Kind) + -> IO (Messages, Maybe Kind) tcRnType hsc_env ictxt rdr_type = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do { @@ -1268,7 +1263,7 @@ tcRnType hsc_env ictxt rdr_type \begin{code} #ifdef GHCI --- ASSUMES that the module is either in the HomePackageTable or is +-- | ASSUMES that the module is either in the 'HomePackageTable' or is -- a package module with an interface on disk. If neither of these is -- true, then the result will be an error indicating the interface -- could not be found. @@ -1301,7 +1296,7 @@ tcGetModuleExports mod directlyImpMods ; ifaceExportNames (mi_exports iface) } -tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name]) +tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Messages, Maybe [Name]) tcRnLookupRdrName hsc_env rdr_name = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env (hsc_IC hsc_env) $ @@ -1336,7 +1331,7 @@ lookup_rdr_name rdr_name = do { return good_names } -tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing) +tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing) tcRnLookupName hsc_env name = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env (hsc_IC hsc_env) $ @@ -1356,7 +1351,7 @@ tcRnLookupName' name = do tcRnGetInfo :: HscEnv -> Name - -> IO (Maybe (TyThing, Fixity, [Instance])) + -> IO (Messages, Maybe (TyThing, Fixity, [Instance])) -- Used to implemnent :info in GHCi -- @@ -1470,8 +1465,16 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, , ppr_fam_insts fam_insts , vcat (map ppr rules) , ppr_gen_tycons (typeEnvTyCons type_env) - , ptext (sLit "Dependent modules:") <+> ppr (eltsUFM (imp_dep_mods imports)) - , ptext (sLit "Dependent packages:") <+> ppr (imp_dep_pkgs imports)] + , ptext (sLit "Dependent modules:") <+> + ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports)) + , ptext (sLit "Dependent packages:") <+> + ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)] + where -- The two uses of sortBy are just to reduce unnecessary + -- wobbling in testsuite output + cmp_mp (mod_name1, is_boot1) (mod_name2, is_boot2) + = (mod_name1 `stableModuleNameCmp` mod_name2) + `thenCmp` + (is_boot1 `compare` is_boot2) pprModGuts :: ModGuts -> SDoc pprModGuts (ModGuts { mg_types = type_env,