X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=30574ae70632e31072bedada0a1a3d974f177c73;hp=b5d5f1672c2da0601fd44884b9f28b4a204a822d;hb=7bb3d1fc79521d591cd9f824893963141a7997b6;hpb=032e31a4f05e6e8e560d113c73dca47c0c18df10 diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index b5d5f16..30574ae 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -34,7 +34,6 @@ import DynFlags import StaticFlags import HsSyn import RdrHsSyn - import PrelNames import RdrName import TcHsSyn @@ -45,6 +44,7 @@ import Inst import FamInst import InstEnv import FamInstEnv +import TcAnnotations import TcBinds import TcDefaults import TcEnv @@ -66,6 +66,7 @@ import PprCore import CoreSyn import ErrUtils import Id +import VarEnv import Var import Module import LazyUniqFM @@ -78,10 +79,13 @@ import SrcLoc import HscTypes import ListSetOps import Outputable +import DataCon +import Type +import Class +import Data.List ( sortBy ) #ifdef GHCI import Linker -import DataCon import TcHsType import TcMType import TcMatches @@ -93,6 +97,7 @@ import IdInfo import {- Kind parts of -} Type import BasicTypes import Foreign.Ptr( Ptr ) +import TidyPgm ( globaliseAndTidyId ) #endif import FastString @@ -103,6 +108,7 @@ import Bag import Control.Monad import Data.Maybe ( isJust ) +#include "HsVersions.h" \end{code} @@ -163,12 +169,12 @@ 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"); + traceRn (text "rn4a: before exports"); tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ; traceRn (text "rn4b: after exportss") ; @@ -176,10 +182,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 ; @@ -229,7 +236,7 @@ tcRnImports hsc_env this_mod import_decls gbl { tcg_rdr_env = plusOccEnv (tcg_rdr_env gbl) rdr_env, tcg_imports = tcg_imports gbl `plusImportAvails` imports, - tcg_rn_imports = fmap (const rn_imports) (tcg_rn_imports gbl), + tcg_rn_imports = rn_imports, tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) home_fam_insts, @@ -251,8 +258,7 @@ tcRnImports hsc_env this_mod import_decls -- Check type-familily consistency ; traceRn (text "rn1: checking family instance consistency") - ; let { dir_imp_mods = map (\ (mod, _) -> mod) - . moduleEnvElts + ; let { dir_imp_mods = moduleEnvKeys . imp_mods $ imports } ; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ; @@ -289,8 +295,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- (in fact, it might not even need to be in the scope of -- this tcg_env at all) avails <- getLocalNonValBinders (mkFakeGroup ldecls) ; - tc_envs <- extendGlobalRdrEnvRn False avails - emptyFsEnv {- no fixity decls -} ; + tc_envs <- extendGlobalRdrEnvRn avails emptyFsEnv {- no fixity decls -} ; setEnvs tc_envs $ do { @@ -301,10 +306,12 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- Typecheck them all together so that -- any mutually recursive types are done right - tcg_env <- tcTyAndClassDecls emptyModDetails rn_decls ; - -- Make the new type env available to stuff slurped from interface files + -- Just discard the auxiliary bindings; they are generated + -- only for Haskell source code, and should already be in Core + (tcg_env, _aux_binds) <- tcTyAndClassDecls emptyModDetails rn_decls ; setGblEnv tcg_env $ do { + -- Make the new type env available to stuff slurped from interface files -- Now the core bindings core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ; @@ -315,7 +322,8 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) my_exports = map (Avail . idName) bndrs ; -- ToDo: export the data types also? - final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ; + final_type_env = + extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ; mod_guts = ModGuts { mg_module = this_mod, mg_boot = False, @@ -334,7 +342,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, @@ -386,8 +394,10 @@ tcRnSrcDecls boot_iface decls -- Even tcSimplifyTop may do some unification. traceTc (text "Tc9") ; let { (tcg_env, _) = tc_envs - ; TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, - tcg_rules = rules, tcg_fords = fords } = tcg_env + ; TcGblEnv { tcg_type_env = type_env, + tcg_binds = binds, + tcg_rules = rules, + tcg_fords = fords } = tcg_env ; all_binds = binds `unionBags` inst_binds } ; failIfErrsM ; -- Don't zonk if there have been errors @@ -396,13 +406,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) @@ -464,26 +474,32 @@ tcRnHsBootDecls decls Nothing -> return () -- Rename the declarations - ; (tcg_env, rn_group) <- rnTopSrcDecls first_group + ; (tcg_env, HsGroup { + hs_tyclds = tycl_decls, + hs_instds = inst_decls, + hs_derivds = deriv_decls, + hs_fords = _, + hs_defds = _, -- Todo: check no foreign decls, no rules, + hs_ruleds = _, -- no default decls and no annotation decls + hs_annds = _, + hs_valds = val_binds }) <- rnTopSrcDecls first_group ; setGblEnv tcg_env $ do { - -- Todo: check no foreign decls, no rules, no default decls -- Typecheck type/class decls ; traceTc (text "Tc2") - ; let tycl_decls = hs_tyclds rn_group - ; tcg_env <- tcTyAndClassDecls emptyModDetails tycl_decls + ; (tcg_env, aux_binds) <- tcTyAndClassDecls emptyModDetails tycl_decls ; setGblEnv tcg_env $ do { -- Typecheck instance decls ; traceTc (text "Tc3") ; (tcg_env, inst_infos, _deriv_binds) - <- tcInstDecls1 tycl_decls (hs_instds rn_group) (hs_derivds rn_group) + <- tcInstDecls1 tycl_decls inst_decls deriv_decls ; setGblEnv tcg_env $ do { -- Typecheck value declarations ; traceTc (text "Tc5") - ; val_ids <- tcHsBootSigs (hs_valds rn_group) + ; val_ids <- tcHsBootSigs val_binds -- Wrap up -- No simplification or zonking to do @@ -492,12 +508,19 @@ tcRnHsBootDecls decls -- Make the final type-env -- Include the dfun_ids so that their type sigs - -- are written into the interface file + -- are written into the interface file. + -- And similarly the aux_ids from aux_binds ; let { type_env0 = tcg_type_env gbl_env ; 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 }) + ; type_env3 = extendTypeEnvWithIds type_env1 aux_ids + ; dfun_ids = map iDFunId inst_infos + ; aux_ids = case aux_binds of + ValBindsOut _ sigs -> [id | L _ (IdSig id) <- sigs] + _ -> panic "tcRnHsBoodDecls" + } + + ; setGlobalTypeEnv gbl_env type_env2 }}}} spliceInHsBootErr (SpliceDecl (L loc _), _) @@ -533,15 +556,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 " ++ @@ -550,7 +564,17 @@ checkHiBootIface -- be the equivalent to the dfun bindings returned for class -- instances? We can't easily equate tycons... - ; return tcg_env' } + -- 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 + ; setGlobalTypeEnv tcg_env' final_type_env } where check_export boot_avail -- boot_avail is exported by the boot iface | name `elem` dfun_names = return () @@ -560,7 +584,8 @@ checkHiBootIface -- Check that the actual module exports the same thing | not (null missing_names) - = addErrTc (missingBootThing (head missing_names) "exported by") + = addErrAt (nameSrcSpan (head missing_names)) + (missingBootThing (head missing_names) "exported by") -- If the boot module does not *define* the thing, we are done -- (it simply re-exports it, and names match, so nothing further to do) @@ -568,13 +593,14 @@ checkHiBootIface -- Check that the actual module also defines the thing, and -- then compare the definitions - | Just real_thing <- lookupTypeEnv local_type_env name - = do { let boot_decl = tyThingToIfaceDecl (fromJust mb_boot_thing) - real_decl = tyThingToIfaceDecl real_thing - ; checkTc (checkBootDecl boot_decl real_decl) - (bootMisMatch real_thing boot_decl real_decl) } - -- The easiest way to check compatibility is to convert to - -- iface syntax, where we already have good comparison functions + | Just real_thing <- lookupTypeEnv local_type_env name, + Just boot_thing <- mb_boot_thing + = when (not (checkBootDecl boot_thing real_thing)) + $ addErrAt (nameSrcSpan (getName boot_thing)) + (let boot_decl = tyThingToIfaceDecl + (fromJust mb_boot_thing) + real_decl = tyThingToIfaceDecl real_thing + in bootMisMatch real_thing boot_decl real_decl) | otherwise = addErrTc (missingBootThing name "defined in") @@ -604,6 +630,103 @@ checkHiBootIface local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty +-- This has to compare the TyThing from the .hi-boot file to the TyThing +-- in the current source file. We must be careful to allow alpha-renaming +-- where appropriate, and also the boot declaration is allowed to omit +-- constructors and class methods. +-- +-- See rnfail055 for a good test of this stuff. + +checkBootDecl :: TyThing -> TyThing -> Bool + +checkBootDecl (AnId id1) (AnId id2) + = ASSERT(id1 == id2) + (idType id1 `tcEqType` idType id2) + +checkBootDecl (ATyCon tc1) (ATyCon tc2) + | isSynTyCon tc1 && isSynTyCon tc2 + = ASSERT(tc1 == tc2) + let tvs1 = tyConTyVars tc1; tvs2 = tyConTyVars tc2 + env = rnBndrs2 env0 tvs1 tvs2 + + eqSynRhs (OpenSynTyCon k1 _) (OpenSynTyCon k2 _) + = tcEqTypeX env k1 k2 + eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2) + = tcEqTypeX env t1 t2 + in + equalLength tvs1 tvs2 && + eqSynRhs (synTyConRhs tc1) (synTyConRhs tc2) + + | isAlgTyCon tc1 && isAlgTyCon tc2 + = ASSERT(tc1 == tc2) + eqListBy tcEqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) + && eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2) + + | isForeignTyCon tc1 && isForeignTyCon tc2 + = tyConExtName tc1 == tyConExtName tc2 + where + env0 = mkRnEnv2 emptyInScopeSet + + eqAlgRhs AbstractTyCon _ = True + eqAlgRhs OpenTyCon{} OpenTyCon{} = True + eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} = + eqListBy eqCon (data_cons tc1) (data_cons tc2) + eqAlgRhs tc1@NewTyCon{} tc2@NewTyCon{} = + eqCon (data_con tc1) (data_con tc2) + eqAlgRhs _ _ = False + + eqCon c1 c2 + = dataConName c1 == dataConName c2 + && dataConIsInfix c1 == dataConIsInfix c2 + && dataConStrictMarks c1 == dataConStrictMarks c2 + && dataConFieldLabels c1 == dataConFieldLabels c2 + && let tvs1 = dataConUnivTyVars c1 ++ dataConExTyVars c1 + tvs2 = dataConUnivTyVars c2 ++ dataConExTyVars c2 + env = rnBndrs2 env0 tvs1 tvs2 + in + equalLength tvs1 tvs2 && + eqListBy (tcEqPredX env) + (dataConEqTheta c1 ++ dataConDictTheta c1) + (dataConEqTheta c2 ++ dataConDictTheta c2) && + eqListBy (tcEqTypeX env) + (dataConOrigArgTys c1) + (dataConOrigArgTys c2) + +checkBootDecl (AClass c1) (AClass c2) + = let + (clas_tyvars1, clas_fds1, sc_theta1, _, _, op_stuff1) + = classExtraBigSig c1 + (clas_tyvars2, clas_fds2, sc_theta2, _, _, op_stuff2) + = classExtraBigSig c2 + + env0 = mkRnEnv2 emptyInScopeSet + env = rnBndrs2 env0 clas_tyvars1 clas_tyvars2 + + eqSig (id1, def_meth1) (id2, def_meth2) + = idName id1 == idName id2 && + tcEqTypeX env op_ty1 op_ty2 + where + (_, rho_ty1) = splitForAllTys (idType id1) + op_ty1 = funResultTy rho_ty1 + (_, rho_ty2) = splitForAllTys (idType id2) + op_ty2 = funResultTy rho_ty2 + + eqFD (as1,bs1) (as2,bs2) = + eqListBy (tcEqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && + eqListBy (tcEqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) + in + equalLength clas_tyvars1 clas_tyvars2 && + eqListBy eqFD clas_fds1 clas_fds2 && + (null sc_theta1 && null op_stuff1 + || + eqListBy (tcEqPredX env) sc_theta1 sc_theta2 && + eqListBy eqSig op_stuff1 op_stuff2) + +checkBootDecl (ADataCon dc1) (ADataCon dc2) + = pprPanic "checkBootDecl" (ppr dc1) + +checkBootDecl _ _ = False -- probably shouldn't happen + ---------------- missingBootThing thing what = ppr thing <+> ptext (sLit "is exported by the hs-boot file, but not") @@ -642,8 +765,8 @@ monad; it augments it and returns the new TcGblEnv. rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name) -- Fails if there are any errors rnTopSrcDecls group - = do { -- Rename the source decls (with no shadowing; error on duplicates) - (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls False group ; + = do { -- Rename the source decls + (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ; -- save the renamed syntax, if we want it let { tcg_env' @@ -666,19 +789,16 @@ tcTopSrcDecls boot_details hs_derivds = deriv_decls, hs_fords = foreign_decls, hs_defds = default_decls, + hs_annds = annotation_decls, hs_ruleds = rule_decls, hs_valds = val_binds }) = do { -- Type-check the type and class decls, and all imported decls -- The latter come in via tycl_decls traceTc (text "Tc2") ; - tcg_env <- tcTyAndClassDecls boot_details tycl_decls ; + (tcg_env, aux_binds) <- 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 @@ -687,8 +807,7 @@ tcTopSrcDecls boot_details <- tcInstDecls1 tycl_decls inst_decls deriv_decls; setGblEnv tcg_env $ do { - -- Foreign import declarations next. No zonking necessary - -- here; we can tuck them straight into the global environment. + -- Foreign import declarations next. traceTc (text "Tc4") ; (fi_ids, fi_decls) <- tcForeignImports foreign_decls ; tcExtendGlobalValEnv fi_ids $ do { @@ -698,28 +817,33 @@ tcTopSrcDecls boot_details default_tys <- tcDefaults default_decls ; updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do { + -- 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) ; + -- Value declarations next - -- We also typecheck any extra binds that came out - -- of the "deriving" process (deriv_binds) traceTc (text "Tc5") ; - (tc_val_binds, tcl_env) <- tcTopBinds val_binds ; - setLclTypeEnv tcl_env $ do { - - -- Now GHC-generated derived bindings and generics. - -- Do not generate warnings from compiler-generated code. - (tc_deriv_binds, tcl_env) <- discardWarnings $ - tcTopBinds deriv_binds ; + (tc_val_binds, tcl_env) <- setLclTypeEnv tcl_env $ + tcTopBinds val_binds; -- Second pass over class and instance declarations, traceTc (text "Tc6") ; - (inst_binds, tcl_env) <- setLclTypeEnv tcl_env $ tcInstDecls2 tycl_decls inst_infos ; - showLIE (text "after instDecls2") ; + (inst_binds, tcl_env) <- setLclTypeEnv tcl_env $ + tcInstDecls2 tycl_decls inst_infos ; + showLIE (text "after instDecls2") ; + + setLclTypeEnv tcl_env $ do { -- Environment doesn't change now -- Foreign exports - -- They need to be zonked, so we return them traceTc (text "Tc7") ; (foe_binds, foe_decls) <- tcForeignExports foreign_decls ; + -- Annotations + annotations <- tcAnnotations annotation_decls ; + -- Rules rules <- tcRules rule_decls ; @@ -728,13 +852,15 @@ tcTopSrcDecls boot_details tcg_env <- getGblEnv ; let { all_binds = tc_val_binds `unionBags` tc_deriv_binds `unionBags` + tc_aux_binds `unionBags` inst_binds `unionBags` - foe_binds ; + foe_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 } } ; return (tcg_env', tcl_env) }}}}}} @@ -762,7 +888,7 @@ check_main dflags tcg_env return tcg_env | otherwise - = do { mb_main <- lookupSrcOcc_maybe main_fn + = do { mb_main <- lookupGlobalOccRn_maybe main_fn -- Check that 'main' is in scope -- It might be imported from another module! ; case mb_main of { @@ -803,11 +929,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 @@ -818,8 +940,15 @@ 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) + +-- | Get the unqualified name of the function to use as the \"main\" for the main module. +-- Either returns the default name or the one configured on the command line with -main-is +getMainFun :: DynFlags -> RdrName +getMainFun dflags = case (mainFunIs dflags) of + Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) + Nothing -> main_RDR_Unqual \end{code} Note [Root-main Id] @@ -876,7 +1005,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. @@ -904,8 +1033,9 @@ tcRnStmt hsc_env ictxt rdr_stmt mapM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ; traceTc (text "tcs 1") ; - let { global_ids = map globaliseAndTidy zonked_ids } ; - + let { global_ids = map globaliseAndTidyId zonked_ids } ; + -- Note [Interactively-bound Ids in GHCi] + {- --------------------------------------------- At one stage I removed any shadowed bindings from the type_env; they are inaccessible but might, I suppose, cause a space leak if we leave them there. @@ -934,12 +1064,6 @@ tcRnStmt hsc_env ictxt rdr_stmt where bad_unboxed id = addErr (sep [ptext (sLit "GHCi can't bind a variable of unlifted type:"), nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) - -globaliseAndTidy :: Id -> Id -globaliseAndTidy id -- Note [Interactively-bound Ids in GHCi] - = Id.setIdType (globaliseId VanillaGlobal id) tidy_type - where - tidy_type = tidyTopType (idType id) \end{code} Note [Interactively-bound Ids in GHCi] @@ -1109,7 +1233,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 { @@ -1138,7 +1262,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 { @@ -1147,7 +1271,7 @@ tcRnType hsc_env ictxt rdr_type failIfErrsM ; -- Now kind-check the type - (ty', kind) <- kcHsType rn_type ; + (ty', kind) <- kcLHsType rn_type ; return kind } where @@ -1165,7 +1289,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. @@ -1198,7 +1322,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) $ @@ -1233,7 +1357,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) $ @@ -1253,7 +1377,7 @@ tcRnLookupName' name = do tcRnGetInfo :: HscEnv -> Name - -> IO (Maybe (TyThing, Fixity, [Instance])) + -> IO (Messages, Maybe (TyThing, Fixity, [Instance])) -- Used to implemnent :info in GHCi -- @@ -1367,8 +1491,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,