X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnNames.lhs;h=76f7bdc9c24cbe1a1c51b39ca4e4b2bb5fd74c6a;hb=f53c4074ff7554ceedaa6b7a5edb2bca7a2d3886;hp=f62fc86f3f6103758d341d688bc965dc298ebffd;hpb=2ffefc1bfca0c8924825cd15750e7ced457f3c81;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index f62fc86..76f7bdc 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -5,7 +5,7 @@ \begin{code} module RnNames ( - getGlobalNames + getGlobalNames, exportsFromAvail ) where #include "HsVersions.h" @@ -14,27 +14,27 @@ import CmdLineOpts ( DynFlag(..) ) import HsSyn ( HsModule(..), HsDecl(..), IE(..), ieName, ImportDecl(..), ForeignDecl(..), ForKind(..), isDynamicExtName, - collectTopBinders + collectLocatedHsBinders ) import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, RdrNameHsModule, RdrNameHsDecl ) -import RnIfaces ( getInterfaceExports, recordLocalSlurps ) -import RnHiFiles ( getTyClDeclBinders ) +import RnIfaces ( recordLocalSlurps ) +import RnHiFiles ( getTyClDeclBinders, loadInterface ) import RnEnv import RnMonad import FiniteMap -import PrelNames ( pRELUDE_Name, mAIN_Name, main_RDR ) +import PrelNames ( pRELUDE_Name, mAIN_Name, main_RDR_Unqual, isUnboundName ) import UniqFM ( lookupUFM ) -import Bag ( bagToList ) import Module ( ModuleName, moduleName, WhereFrom(..) ) import NameSet -import Name ( Name, nameSrcLoc, - setLocalNameSort, nameOccName, nameEnvElts ) +import Name ( Name, nameSrcLoc, nameOccName, nameEnvElts ) import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv, - GenAvailInfo(..), AvailInfo, Avails, AvailEnv ) -import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual ) + GenAvailInfo(..), AvailInfo, Avails, AvailEnv, + Deprecations(..), ModIface(..) + ) +import RdrName ( rdrNameOcc, setRdrNameOcc ) import OccName ( setOccNameSpace, dataName ) import NameSet ( elemNameSet, emptyNameSet ) import Outputable @@ -57,27 +57,13 @@ import List ( partition ) getGlobalNames :: Module -> RdrNameHsModule -> RnMG (GlobalRdrEnv, -- Maps all in-scope things GlobalRdrEnv, -- Maps just *local* things - Avails, -- The exported stuff - AvailEnv) -- Maps a name to its parent AvailInfo - -- Just for in-scope things only - -getGlobalNames this_mod (HsModule _ _ exports imports decls _ mod_loc) - = -- These two fix-loops are to get the right - -- provenance information into a Name - fixRn ( \ ~(rec_gbl_env, _, rec_export_avails, _) -> - - let - rec_unqual_fn :: Name -> Bool -- Is this chap in scope unqualified? - rec_unqual_fn = unQualInScope rec_gbl_env + ExportAvails) -- The exported stuff - rec_exp_fn :: Name -> Bool - rec_exp_fn = mk_export_fn (availsToNameSet rec_export_avails) - in - - -- PROCESS LOCAL DECLS +getGlobalNames this_mod (HsModule _ _ _ imports decls _ mod_loc) + = -- PROCESS LOCAL DECLS -- Do these *first* so that the correct provenance gets -- into the global name cache. - importsFromLocalDecls this_mod rec_exp_fn decls `thenRn` \ (local_gbl_env, local_mod_avails) -> + importsFromLocalDecls this_mod decls `thenRn` \ (local_gbl_env, local_mod_avails) -> -- PROCESS IMPORT DECLS -- Do the non {- SOURCE -} ones first, so that we get a helpful @@ -89,7 +75,7 @@ getGlobalNames this_mod (HsModule _ _ exports imports decls _ mod_loc) is_source_import (ImportDecl _ ImportByUserSource _ _ _ _) = True is_source_import other = False - get_imports = importsFromImportDecl this_mod_name rec_unqual_fn + get_imports = importsFromImportDecl this_mod_name in mapAndUnzipRn get_imports ordinary `thenRn` \ (imp_gbl_envs1, imp_avails_s1) -> mapAndUnzipRn get_imports source `thenRn` \ (imp_gbl_envs2, imp_avails_s2) -> @@ -104,21 +90,10 @@ getGlobalNames this_mod (HsModule _ _ exports imports decls _ mod_loc) all_avails :: ExportAvails all_avails = foldr plusExportAvails local_mod_avails (imp_avails_s2 ++ imp_avails_s1) - - (_, global_avail_env) = all_avails in - -- PROCESS EXPORT LIST (but not if we've had errors already) - checkErrsRn `thenRn` \ no_errs_so_far -> - (if no_errs_so_far then - exportsFromAvail this_mod_name exports all_avails gbl_env - else - returnRn [] - ) `thenRn` \ export_avails -> - -- ALL DONE - returnRn (gbl_env, local_gbl_env, export_avails, global_avail_env) - ) + returnRn (gbl_env, local_gbl_env, all_avails) where this_mod_name = moduleName this_mod @@ -144,22 +119,20 @@ getGlobalNames this_mod (HsModule _ _ exports imports decls _ mod_loc) \begin{code} importsFromImportDecl :: ModuleName - -> (Name -> Bool) -- OK to omit qualifier -> RdrNameImportDecl -> RnMG (GlobalRdrEnv, ExportAvails) -importsFromImportDecl this_mod_name is_unqual (ImportDecl imp_mod_name from qual_only as_mod import_spec iloc) +importsFromImportDecl this_mod_name (ImportDecl imp_mod_name from qual_only as_mod import_spec iloc) = pushSrcLocRn iloc $ - getInterfaceExports imp_mod_name from `thenRn` \ (imp_mod, avails_by_module) -> - - if null avails_by_module then - -- If there's an error in getInterfaceExports, (e.g. interface - -- file not found) we get lots of spurious errors from 'filterImports' - returnRn (emptyRdrEnv, mkEmptyExportAvails imp_mod_name) - else + loadInterface (ppr imp_mod_name <+> ptext SLIT("is directly imported")) + imp_mod_name from `thenRn` \ iface -> let + imp_mod = mi_module iface + avails_by_module = mi_exports iface + deprecs = mi_deprecs iface + avails :: Avails avails = [ avail | (mod_name, avails) <- avails_by_module, mod_name /= this_mod_name, @@ -182,25 +155,39 @@ importsFromImportDecl this_mod_name is_unqual (ImportDecl imp_mod_name from qual -- then you'll get a 'B does not export AType' message. Oh well. in - filterImports imp_mod_name import_spec avails `thenRn` \ (filtered_avails, hides, explicits) -> + if null avails_by_module then + -- If there's an error in loadInterface, (e.g. interface + -- file not found) we get lots of spurious errors from 'filterImports' + returnRn (emptyRdrEnv, mkEmptyExportAvails imp_mod_name) + else + + -- Complain if we import a deprecated module + (case deprecs of + DeprecAll txt -> addWarnRn (moduleDeprec imp_mod_name txt) + other -> returnRn () + ) `thenRn_` + + -- Filter the imports according to the import list + filterImports imp_mod_name from import_spec avails `thenRn` \ (filtered_avails, hides, explicits) -> let - mk_provenance name = NonLocalDef (UserImport imp_mod iloc (name `elemNameSet` explicits)) - (is_unqual name) + unqual_imp = not qual_only -- Maybe want unqualified names + qual_mod = case as_mod of + Nothing -> imp_mod_name + Just another_name -> another_name + + mk_prov name = NonLocalDef (UserImport imp_mod iloc (name `elemNameSet` explicits)) + gbl_env = mkGlobalRdrEnv qual_mod unqual_imp True hides mk_prov filtered_avails deprecs + exports = mkExportAvails qual_mod unqual_imp gbl_env filtered_avails in - - qualifyImports imp_mod_name - (not qual_only) -- Maybe want unqualified names - as_mod hides - mk_provenance - filtered_avails + returnRn (gbl_env, exports) \end{code} \begin{code} -importsFromLocalDecls this_mod rec_exp_fn decls - = mapRn (getLocalDeclBinders this_mod rec_exp_fn) decls `thenRn` \ avails_s -> - +importsFromLocalDecls this_mod decls + = mapRn (getLocalDeclBinders this_mod) decls `thenRn` \ avails_s -> + -- The avails that are returned don't include the "system" names let avails = concat avails_s @@ -211,39 +198,53 @@ importsFromLocalDecls this_mod rec_exp_fn decls (_, dups) = removeDups compare all_names in -- Check for duplicate definitions - mapRn_ (addErrRn . dupDeclErr) dups `thenRn_` + mapRn_ (addErrRn . dupDeclErr) dups `thenRn_` - -- Record that locally-defined things are available - recordLocalSlurps avails `thenRn_` - -- Build the environment - qualifyImports (moduleName this_mod) - True -- Want unqualified names - Nothing -- no 'as M' - [] -- Hide nothing - (\n -> LocalDef) -- Provenance is local - avails + -- Record that locally-defined things are available + recordLocalSlurps (availsToNameSet avails) `thenRn_` + let + mod_name = moduleName this_mod + unqual_imp = True -- Want unqualified names + mk_prov n = LocalDef -- Provenance is local + hides = [] -- Hide nothing + + gbl_env = mkGlobalRdrEnv mod_name unqual_imp True hides mk_prov avails NoDeprecs + -- NoDeprecs: don't complain about locally defined names + -- For a start, we may be exporting a deprecated thing + -- Also we may use a deprecated thing in the defn of another + -- deprecated things. We may even use a deprecated thing in + -- the defn of a non-deprecated thing, when changing a module's + -- interface + + exports = mkExportAvails mod_name unqual_imp gbl_env avails + in + returnRn (gbl_env, exports) --------------------------- -getLocalDeclBinders :: Module - -> (Name -> Bool) -- Whether exported - -> RdrNameHsDecl -> RnMG Avails -getLocalDeclBinders mod rec_exp_fn (TyClD tycl_decl) +getLocalDeclBinders :: Module -> RdrNameHsDecl -> RnMG [AvailInfo] +getLocalDeclBinders mod (TyClD tycl_decl) = -- For type and class decls, we generate Global names, with -- no export indicator. They need to be global because they get -- permanently bound into the TyCons and Classes. They don't need -- an export indicator because they are all implicitly exported. - getTyClDeclBinders mod tycl_decl `thenRn` \ avail -> + getTyClDeclBinders mod tycl_decl `thenRn` \ (avail, sys_names) -> + + -- Record that the system names are available + recordLocalSlurps (mkNameSet sys_names) `thenRn_` returnRn [avail] -getLocalDeclBinders mod rec_exp_fn (ValD binds) - = mapRn (newLocalBinder mod rec_exp_fn) - (bagToList (collectTopBinders binds)) +getLocalDeclBinders mod (ValD binds) + = mapRn new (collectLocatedHsBinders binds) `thenRn` \ avails -> + returnRn avails + where + new (rdr_name, loc) = newTopBinder mod rdr_name loc `thenRn` \ name -> + returnRn (Avail name) -getLocalDeclBinders mod rec_exp_fn (ForD (ForeignDecl nm kind _ ext_nm _ loc)) +getLocalDeclBinders mod (ForD (ForeignDecl nm kind _ ext_nm _ loc)) | binds_haskell_name kind - = newLocalBinder mod rec_exp_fn (nm, loc) `thenRn` \ avail -> - returnRn [avail] + = newTopBinder mod nm loc `thenRn` \ name -> + returnRn [Avail name] | otherwise -- a foreign export = returnRn [] @@ -252,17 +253,11 @@ getLocalDeclBinders mod rec_exp_fn (ForD (ForeignDecl nm kind _ ext_nm _ loc)) binds_haskell_name FoLabel = True binds_haskell_name FoExport = isDynamicExtName ext_nm -getLocalDeclBinders mod rec_exp_fn (FixD _) = returnRn [] -getLocalDeclBinders mod rec_exp_fn (DeprecD _) = returnRn [] -getLocalDeclBinders mod rec_exp_fn (DefD _) = returnRn [] -getLocalDeclBinders mod rec_exp_fn (InstD _) = returnRn [] -getLocalDeclBinders mod rec_exp_fn (RuleD _) = returnRn [] - ---------------------------- -newLocalBinder mod rec_exp_fn (rdr_name, loc) - = -- Generate a local name, and with a suitable export indicator - newTopBinder mod rdr_name loc `thenRn` \ name -> - returnRn (Avail (setLocalNameSort name (rec_exp_fn name))) +getLocalDeclBinders mod (FixD _) = returnRn [] +getLocalDeclBinders mod (DeprecD _) = returnRn [] +getLocalDeclBinders mod (DefD _) = returnRn [] +getLocalDeclBinders mod (InstD _) = returnRn [] +getLocalDeclBinders mod (RuleD _) = returnRn [] \end{code} @@ -277,6 +272,7 @@ available, and filters it through the import spec (if any). \begin{code} filterImports :: ModuleName -- The module being imported + -> WhereFrom -- Tells whether it's a {-# SOURCE #-} import -> Maybe (Bool, [RdrNameIE]) -- Import spec; True => hiding -> [AvailInfo] -- What's available -> RnMG ([AvailInfo], -- What's actually imported @@ -289,10 +285,10 @@ filterImports :: ModuleName -- The module being imported -- Complains if import spec mentions things that the module doesn't export -- Warns/informs if import spec contains duplicates. -filterImports mod Nothing imports +filterImports mod from Nothing imports = returnRn (imports, [], emptyNameSet) -filterImports mod (Just (want_hiding, import_items)) total_avails +filterImports mod from (Just (want_hiding, import_items)) total_avails = flatMapRn get_item import_items `thenRn` \ avails_w_explicits -> let (item_avails, explicits_s) = unzip avails_w_explicits @@ -314,7 +310,7 @@ filterImports mod (Just (want_hiding, import_items)) total_avails -- they won't make any difference because naked entities like T -- in an import list map to TcOccs, not VarOccs. - bale_out item = addErrRn (badImportItemErr mod item) `thenRn_` + bale_out item = addErrRn (badImportItemErr mod from item) `thenRn_` returnRn [] get_item item@(IEModuleContents _) = bale_out item @@ -369,65 +365,12 @@ filterImports mod (Just (want_hiding, import_items)) total_avails %* * %************************************************************************ -@qualifyImports@ takes the @ExportEnv@ after filtering through the import spec -of an import decl, and deals with producing an @RnEnv@ with the -right qualified names. It also turns the @Names@ in the @ExportEnv@ into -fully fledged @Names@. - \begin{code} -qualifyImports :: ModuleName -- Imported module - -> Bool -- True <=> want unqualified import - -> Maybe ModuleName -- Optional "as M" part - -> [AvailInfo] -- What's to be hidden - -> (Name -> Provenance) - -> Avails -- Whats imported and how - -> RnMG (GlobalRdrEnv, ExportAvails) - -qualifyImports this_mod unqual_imp as_mod hides mk_provenance avails - = - -- Make the name environment. We're talking about a - -- single module here, so there must be no name clashes. - -- In practice there only ever will be if it's the module - -- being compiled. - let - -- Add the things that are available - name_env1 = foldl add_avail emptyRdrEnv avails - - -- Delete things that are hidden - name_env2 = foldl del_avail name_env1 hides - - -- Create the export-availability info - export_avails = mkExportAvails qual_mod unqual_imp name_env2 avails - in - returnRn (name_env2, export_avails) - - where - qual_mod = case as_mod of - Nothing -> this_mod - Just another_name -> another_name - - add_avail :: GlobalRdrEnv -> AvailInfo -> GlobalRdrEnv - add_avail env avail = foldl add_name env (availNames avail) - - add_name env name - | unqual_imp = env2 - | otherwise = env1 - where - env1 = addOneToGlobalRdrEnv env (mkRdrQual qual_mod occ) (name,prov) - env2 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) (name,prov) - occ = nameOccName name - prov = mk_provenance name - - del_avail env avail = foldl delOneFromGlobalRdrEnv env rdr_names - where - rdr_names = map (mkRdrUnqual . nameOccName) (availNames avail) - - mkEmptyExportAvails :: ModuleName -> ExportAvails mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyUFM) mkExportAvails :: ModuleName -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails -mkExportAvails mod_name unqual_imp name_env avails +mkExportAvails mod_name unqual_imp gbl_env avails = (mod_avail_env, entity_avail_env) where mod_avail_env = unitFM mod_name unqual_avails @@ -448,7 +391,7 @@ mkExportAvails mod_name unqual_imp name_env avails where uqs = filter unqual_in_scope ns - unqual_in_scope n = unQualInScope name_env n + unqual_in_scope n = unQualInScope gbl_env n entity_avail_env = listToUFM [ (name,avail) | avail <- avails, name <- availNames avail] @@ -505,7 +448,7 @@ exportsFromAvail this_mod Nothing export_avails global_name_env = exportsFromAvail this_mod true_exports export_avails global_name_env where true_exports = Just $ if this_mod == mAIN_Name - then [IEVar main_RDR] + then [IEVar main_RDR_Unqual] -- export Main.main *only* unless otherwise specified, else [IEModuleContents this_mod] -- but for all other modules export everything. @@ -542,46 +485,38 @@ exportsFromAvail this_mod (Just export_items) returnRn (mod:mods, occs', avails') exports_from_item warn_dups acc@(mods, occs, avails) ie - | not (maybeToBool maybe_in_scope) - = failWithRn acc (unknownNameErr (ieName ie)) - - | not (null dup_names) - = addNameClashErrRn rdr_name ((name,prov):dup_names) `thenRn_` - returnRn acc + = lookupSrcName global_name_env (ieName ie) `thenRn` \ name -> -#ifdef DEBUG - -- I can't see why this should ever happen; if the thing is in scope - -- at all it ought to have some availability - | not (maybeToBool maybe_avail) - = pprTrace "exportsFromAvail: curious Nothing:" (ppr name) - returnRn acc -#endif + -- See what's available in the current environment + case lookupUFM entity_avail_env name of { + Nothing -> -- Presumably this happens because lookupSrcName didn't find + -- the name and returned an unboundName, which won't be in + -- the entity_avail_env, of course + WARN( not (isUnboundName name), ppr name ) + returnRn acc ; - | not enough_avail - = failWithRn acc (exportItemErr ie) + Just avail -> - | otherwise -- Phew! It's OK! Now to check the occurrence stuff! + -- Filter out the bits we want + case filterAvail ie avail of { + Nothing -> -- Not enough availability + failWithRn acc (exportItemErr ie) ; + Just export_avail -> - = warnCheckRn (ok_item ie avail) (dodgyExportWarn ie) `thenRn_` + -- Phew! It's OK! Now to check the occurrence stuff! + warnCheckRn (ok_item ie avail) (dodgyExportWarn ie) `thenRn_` check_occs ie occs export_avail `thenRn` \ occs' -> returnRn (mods, occs', addAvail avails export_avail) + }} + + - where - rdr_name = ieName ie - maybe_in_scope = lookupFM global_name_env rdr_name - Just ((name,prov):dup_names) = maybe_in_scope - maybe_avail = lookupUFM entity_avail_env name - Just avail = maybe_avail - maybe_export_avail = filterAvail ie avail - enough_avail = maybeToBool maybe_export_avail - Just export_avail = maybe_export_avail - - ok_item (IEThingAll _) (AvailTC _ [n]) = False - -- This occurs when you import T(..), but - -- only export T abstractly. The single [n] - -- in the AvailTC is the type or class itself - ok_item _ _ = True +ok_item (IEThingAll _) (AvailTC _ [n]) = False + -- This occurs when you import T(..), but + -- only export T abstractly. The single [n] + -- in the AvailTC is the type or class itself +ok_item _ _ = True check_occs :: RdrNameIE -> ExportOccMap -> AvailInfo -> RnMG ExportOccMap check_occs ie occs avail @@ -601,9 +536,6 @@ check_occs ie occs avail failWithRn occs (exportClashErr name_occ ie ie') where name_occ = nameOccName name - -mk_export_fn :: NameSet -> (Name -> Bool) -- True => exported -mk_export_fn exported_names = \name -> name `elemNameSet` exported_names \end{code} %************************************************************************ @@ -613,9 +545,13 @@ mk_export_fn exported_names = \name -> name `elemNameSet` exported_names %************************************************************************ \begin{code} -badImportItemErr mod ie - = sep [ptext SLIT("Module"), quotes (ppr mod), +badImportItemErr mod from ie + = sep [ptext SLIT("Module"), quotes (ppr mod), source_import, ptext SLIT("does not export"), quotes (ppr ie)] + where + source_import = case from of + ImportByUserSource -> ptext SLIT("(hi-boot interface)") + other -> empty dodgyImportWarn mod item = dodgyMsg (ptext SLIT("import")) item dodgyExportWarn item = dodgyMsg (ptext SLIT("export")) item @@ -653,4 +589,8 @@ dupModuleExport mod = hsep [ptext SLIT("Duplicate"), quotes (ptext SLIT("Module") <+> ppr mod), ptext SLIT("in export list")] + +moduleDeprec mod txt + = sep [ ptext SLIT("Module") <+> quotes (ppr mod) <+> ptext SLIT("is deprecated:"), + nest 4 (ppr txt) ] \end{code}