X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnDriver.lhs;h=5032f01b2e65c3ce3b09ae7d0fbcb1229a76a760;hb=b3fe66bb78fe11ee322f7442a5676e628f678b29;hp=676792b0b9e756d7fb0f298ad7b218d1b9a035d7;hpb=0cf6f8c36250e64b5b2bdf0bd6ed10e71984becc;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 676792b..5032f01 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -21,12 +21,14 @@ import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) #endif import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt ) +import Packages ( moduleToPackageConfig, mkPackageId, package, + isHomeModule ) import DriverState ( v_MainModIs, v_MainFunIs ) import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, SpliceDecl(..), HsBind(..), nlHsApp, nlHsVar, pprLHsBinds ) import RdrHsSyn ( findSplice ) -import PrelNames ( runIOName, rootMainName, mAIN_Name, +import PrelNames ( runIOName, rootMainName, mAIN, main_RDR_Unqual ) import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv, plusGlobalRdrEnv ) @@ -45,8 +47,7 @@ import TcIface ( tcExtCoreBindings ) import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls ) import LoadIface ( loadOrphanModules, loadHiBootInterface ) -import IfaceEnv ( lookupOrig ) -import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail, +import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail, reportUnusedNames, reportDeprecations ) import RnEnv ( lookupSrcOcc_maybe ) import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec ) @@ -56,7 +57,7 @@ import DataCon ( dataConWrapId ) import ErrUtils ( Messages, mkDumpDoc, showPass ) import Id ( mkExportedLocalId, isLocalId, idName, idType ) import Var ( Var ) -import Module ( mkHomeModule, mkModuleName, moduleName, moduleEnvElts ) +import Module ( mkModule, moduleEnvElts ) import OccName ( mkVarOcc ) import Name ( Name, isExternalName, getSrcLoc, getOccName ) import NameSet @@ -64,12 +65,12 @@ import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind ) import SrcLoc ( srcLocSpan, Located(..), noLoc ) import Outputable import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState(..), - GhciMode(..), noDependencies, isOneShot, - Deprecs( NoDeprecs ), ModIface(..), plusDeprecs, + GhciMode(..), noDependencies, + Deprecs( NoDeprecs ), plusDeprecs, ForeignStubs(NoStubs), TyThing(..), TypeEnv, lookupTypeEnv, extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, - emptyFixityEnv, availName + emptyFixityEnv ) #ifdef GHCI import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..), @@ -110,10 +111,10 @@ import IdInfo ( GlobalIdDetails(..) ) import SrcLoc ( interactiveSrcLoc, unLoc ) import Kind ( Kind ) import Var ( globaliseId ) -import Name ( nameOccName, nameModuleName ) +import Name ( nameOccName, nameModule ) import NameEnv ( delListFromNameEnv ) import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName ) -import Module ( ModuleName, lookupModuleEnvByName ) +import Module ( Module, lookupModuleEnv ) import HscTypes ( InteractiveContext(..), ExternalPackageState( eps_PTE ), HomeModInfo(..), typeEnvElts, typeEnvClasses, availNames, icPrintUnqual, @@ -146,19 +147,22 @@ tcRnModule :: HscEnv -> Located (HsModule RdrName) -> IO (Messages, Maybe TcGblEnv) -tcRnModule hsc_env (L loc (HsModule maybe_mod exports +tcRnModule hsc_env (L loc (HsModule maybe_mod export_ies import_decls local_decls mod_deprec)) = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; let { this_mod = case maybe_mod of - Nothing -> mkHomeModule mAIN_Name + Nothing -> mAIN -- 'module M where' is omitted Just (L _ mod) -> mod } ; -- The normal case initTc hsc_env this_mod $ setSrcSpan loc $ - do { -- Deal with imports; sets tcg_rdr_env, tcg_imports + do { + checkForPackageModule (hsc_dflags hsc_env) this_mod; + + -- Deal with imports; sets tcg_rdr_env, tcg_imports (rdr_env, imports) <- rnImports import_decls ; -- Record boot-file info in the EPS, so that it's @@ -195,20 +199,7 @@ tcRnModule hsc_env (L loc (HsModule maybe_mod exports reportDeprecations tcg_env ; -- Process the export list - exports <- exportsFromAvail (isJust maybe_mod) exports ; - -{- Jan 04: I don't think this is necessary any more; usage info is derived from tcg_dus - -- Get any supporting decls for the exports that have not already - -- been sucked in for the declarations in the body of the module. - -- (This can happen if something is imported only to be re-exported.) - -- - -- Importing these supporting declarations is required - -- *only* to gether usage information - -- (see comments with MkIface.mkImportInfo for why) - -- We don't need the results, but sucking them in may side-effect - -- the ExternalPackageState, apart from recording usage - mappM (tcLookupGlobal . availName) export_avails ; --} + exports <- exportsFromAvail (isJust maybe_mod) export_ies ; -- Check whether the entire module is deprecated -- This happens only once per module @@ -229,6 +220,22 @@ tcRnModule hsc_env (L loc (HsModule maybe_mod exports tcDump final_env ; return final_env }}}} + +-- This is really a sanity check that the user has given -package-name +-- if necessary. -package-name is only necessary when the package database +-- already contains the current package, because then we can't tell +-- whether a given module is in the current package or not, without knowing +-- the name of the current package. +checkForPackageModule dflags this_mod + | not (isHomeModule dflags this_mod), + Just (pkg,_) <- moduleToPackageConfig dflags this_mod = + let + ppr_pkg = ppr (mkPackageId (package pkg)) + in + addErr (ptext SLIT("Module") <+> quotes (ppr this_mod) <+> + ptext SLIT("is a member of package") <+> ppr_pkg <> char '.' $$ + ptext SLIT("To compile this module, please use -ignore-package") <+> ppr_pkg <> char '.') + | otherwise = return () \end{code} @@ -621,8 +628,8 @@ checkMain mb_main_mod <- readMutVar v_MainModIs ; mb_main_fn <- readMutVar v_MainFunIs ; let { main_mod = case mb_main_mod of { - Just mod -> mkModuleName mod ; - Nothing -> mAIN_Name } ; + Just mod -> mkModule mod ; + Nothing -> mAIN } ; main_fn = case mb_main_fn of { Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ; Nothing -> main_RDR_Unqual } } ; @@ -635,12 +642,9 @@ check_main ghci_mode tcg_env main_mod main_fn -- If we are in module Main, check that 'main' is defined. -- It may be imported from another module! -- - -- ToDo: We have to return the main_name separately, because it's a - -- bona fide 'use', and should be recorded as such, but the others - -- aren't -- -- Blimey: a whole page of code to do this... - | mod_name /= main_mod + | mod /= main_mod = return tcg_env | otherwise @@ -665,10 +669,12 @@ check_main ghci_mode tcg_env main_mod main_fn `snocBag` main_bind, tcg_dus = tcg_dus tcg_env `plusDU` usesOnly (unitFV main_name) + -- Record the use of 'main', so that we don't + -- complain about it being defined but not used }) }}} where - mod_name = moduleName (tcg_mod tcg_env) + mod = tcg_mod tcg_env complain_no_main | ghci_mode == Interactive = return () | otherwise = failWithTc noMainMsg @@ -947,7 +953,7 @@ tcRnType hsc_env ictxt rdr_type \begin{code} #ifdef GHCI -mkExportEnv :: HscEnv -> [ModuleName] -- Expose these modules' exports only +mkExportEnv :: HscEnv -> [Module] -- Expose these modules' exports only -> IO GlobalRdrEnv mkExportEnv hsc_env exports = do { mb_envs <- initTcPrintErrors hsc_env iNTERACTIVE $ @@ -958,7 +964,7 @@ mkExportEnv hsc_env exports -- Some error; initTc will have printed it } -getModuleExports :: ModuleName -> TcM GlobalRdrEnv +getModuleExports :: Module -> TcM GlobalRdrEnv getModuleExports mod = do { iface <- load_iface mod ; loadOrphanModules (dep_orphs (mi_deps iface)) @@ -966,10 +972,10 @@ getModuleExports mod -- so their instances are visible ; avails <- exportsToAvails (mi_exports iface) ; let { gres = [ GRE { gre_name = name, gre_prov = vanillaProv mod } - | avail <- avails, name <- availNames avail ] } + | avail <- nameSetToList avails ] } ; returnM (mkGlobalRdrEnv gres) } -vanillaProv :: ModuleName -> Provenance +vanillaProv :: Module -> Provenance -- We're building a GlobalRdrEnv as if the user imported -- all the specified modules into the global interactive module vanillaProv mod = Imported [ImportSpec mod mod False @@ -980,7 +986,7 @@ vanillaProv mod = Imported [ImportSpec mod mod False getModuleContents :: HscEnv -> InteractiveContext - -> ModuleName -- Module to inspect + -> Module -- Module to inspect -> Bool -- Grab just the exports, or the whole toplev -> IO (Maybe [IfaceDecl]) @@ -991,7 +997,7 @@ getModuleContents hsc_env ictxt mod exports_only | not exports_only -- We want the whole top-level type env -- so it had better be a home module = do { hpt <- getHpt - ; case lookupModuleEnvByName hpt mod of + ; case lookupModuleEnv hpt mod of Just mod_info -> return (map toIfaceDecl $ filter wantToSee $ typeEnvElts $ @@ -1002,13 +1008,14 @@ getModuleContents hsc_env ictxt mod exports_only | otherwise -- Want the exports only = do { iface <- load_iface mod - ; avails <- exportsToAvails (mi_exports iface) - ; mappM get_decl avails + ; mappM get_decl [ (mod,avail) | (mod, avails) <- mi_exports iface + , avail <- avails ] } - get_decl avail - = do { thing <- tcLookupGlobal (availName avail) - ; return (filter_decl (availOccs avail) (toIfaceDecl thing)) } + get_decl (mod, avail) + = do { main_name <- lookupOrig mod (availName avail) + ; thing <- tcLookupGlobal main_name + ; return (filter_decl (availNames avail) (toIfaceDecl thing)) } --------------------- filter_decl occs decl@(IfaceClass {ifSigs = sigs}) @@ -1024,8 +1031,6 @@ filter_decl occs decl keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs keep_con occs con = ifConOcc con `elem` occs -availOccs avail = map nameOccName (availNames avail) - wantToSee (AnId id) = not (isImplicitId id) wantToSee (ADataCon _) = False -- They'll come via their TyCon wantToSee _ = True @@ -1129,7 +1134,7 @@ toIfaceDecl thing emptyNameSet -- Show data cons ext_nm (munge thing) where - ext_nm n = ExtPkg (nameModuleName n) (nameOccName n) + ext_nm n = ExtPkg (nameModule n) (nameOccName n) -- munge transforms a thing to it's "parent" thing munge (ADataCon dc) = ATyCon (dataConTyCon dc)