X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnNames.lhs;h=078863f83cd0f8d6e5b2d6418170e3799e6b6fcc;hb=c5ba8422faef9ee65d28e706c320cc334f9e97b6;hp=76f7bdc9c24cbe1a1c51b39ca4e4b2bb5fd74c6a;hpb=f53c4074ff7554ceedaa6b7a5edb2bca7a2d3886;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 76f7bdc..078863f 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -13,7 +13,7 @@ module RnNames ( import CmdLineOpts ( DynFlag(..) ) import HsSyn ( HsModule(..), HsDecl(..), IE(..), ieName, ImportDecl(..), - ForeignDecl(..), ForKind(..), isDynamicExtName, + ForeignDecl(..), collectLocatedHsBinders ) import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, @@ -26,20 +26,19 @@ import RnMonad import FiniteMap import PrelNames ( pRELUDE_Name, mAIN_Name, main_RDR_Unqual, isUnboundName ) -import UniqFM ( lookupUFM ) import Module ( ModuleName, moduleName, WhereFrom(..) ) +import Name ( Name, nameSrcLoc, nameOccName ) import NameSet -import Name ( Name, nameSrcLoc, nameOccName, nameEnvElts ) +import NameEnv import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv, GenAvailInfo(..), AvailInfo, Avails, AvailEnv, - Deprecations(..), ModIface(..) + Deprecations(..), ModIface(..), emptyAvailEnv ) import RdrName ( rdrNameOcc, setRdrNameOcc ) import OccName ( setOccNameSpace, dataName ) import NameSet ( elemNameSet, emptyNameSet ) import Outputable import Maybes ( maybeToBool, catMaybes, mapMaybe ) -import UniqFM ( emptyUFM, listToUFM ) import ListSetOps ( removeDups ) import Util ( sortLt ) import List ( partition ) @@ -162,9 +161,10 @@ importsFromImportDecl this_mod_name (ImportDecl imp_mod_name from qual_only as_m else -- Complain if we import a deprecated module - (case deprecs of - DeprecAll txt -> addWarnRn (moduleDeprec imp_mod_name txt) - other -> returnRn () + ifOptRn Opt_WarnDeprecations ( + case deprecs of + DeprecAll txt -> addWarnRn (moduleDeprec imp_mod_name txt) + other -> returnRn () ) `thenRn_` -- Filter the imports according to the import list @@ -177,8 +177,8 @@ importsFromImportDecl this_mod_name (ImportDecl imp_mod_name from qual_only as_m 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 + gbl_env = mkGlobalRdrEnv qual_mod unqual_imp mk_prov filtered_avails hides deprecs + exports = mkExportAvails qual_mod unqual_imp gbl_env hides filtered_avails in returnRn (gbl_env, exports) \end{code} @@ -198,6 +198,9 @@ importsFromLocalDecls this_mod decls (_, dups) = removeDups compare all_names in -- Check for duplicate definitions + -- The complaint will come out as "Multiple declarations of Foo.f" because + -- since 'f' is in the env twice, the unQualInScope used by the error-msg + -- printer returns False. It seems awkward to fix, unfortunately. mapRn_ (addErrRn . dupDeclErr) dups `thenRn_` @@ -209,7 +212,7 @@ importsFromLocalDecls this_mod decls mk_prov n = LocalDef -- Provenance is local hides = [] -- Hide nothing - gbl_env = mkGlobalRdrEnv mod_name unqual_imp True hides mk_prov avails NoDeprecs + gbl_env = mkGlobalRdrEnv mod_name unqual_imp mk_prov avails hides 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 @@ -217,7 +220,7 @@ importsFromLocalDecls this_mod decls -- the defn of a non-deprecated thing, when changing a module's -- interface - exports = mkExportAvails mod_name unqual_imp gbl_env avails + exports = mkExportAvails mod_name unqual_imp gbl_env hides avails in returnRn (gbl_env, exports) @@ -241,17 +244,11 @@ getLocalDeclBinders mod (ValD binds) new (rdr_name, loc) = newTopBinder mod rdr_name loc `thenRn` \ name -> returnRn (Avail name) -getLocalDeclBinders mod (ForD (ForeignDecl nm kind _ ext_nm _ loc)) - | binds_haskell_name kind +getLocalDeclBinders mod (ForD (ForeignImport nm _ _ loc)) = newTopBinder mod nm loc `thenRn` \ name -> returnRn [Avail name] - - | otherwise -- a foreign export +getLocalDeclBinders mod (ForD _) = returnRn [] - where - binds_haskell_name (FoImport _) = True - binds_haskell_name FoLabel = True - binds_haskell_name FoExport = isDynamicExtName ext_nm getLocalDeclBinders mod (FixD _) = returnRn [] getLocalDeclBinders mod (DeprecD _) = returnRn [] @@ -275,12 +272,12 @@ 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 - [AvailInfo], -- What's to be hidden - -- (the unqualified version, that is) - -- (We need to return both the above sets, because - -- the qualified version is never hidden; so we can't - -- implement hiding by reducing what's imported.) + -> RnMG ([AvailInfo], -- "chosens" + [AvailInfo], -- "hides" + -- The true imports are "chosens" - "hides" + -- (It's convenient to return both the above sets, because + -- the substraction can be done more efficiently when + -- building the environment.) NameSet) -- What was imported explicitly -- Complains if import spec mentions things that the module doesn't export @@ -313,6 +310,7 @@ filterImports mod from (Just (want_hiding, import_items)) total_avails bale_out item = addErrRn (badImportItemErr mod from item) `thenRn_` returnRn [] + get_item :: RdrNameIE -> RnMG [(AvailInfo, [Name])] get_item item@(IEModuleContents _) = bale_out item get_item item@(IEThingAll _) @@ -321,14 +319,14 @@ filterImports mod from (Just (want_hiding, import_items)) total_avails Just avail@(AvailTC _ [n]) -> -- This occurs when you import T(..), but -- only export T abstractly. The single [n] -- in the AvailTC is the type or class itself - addWarnRn (dodgyImportWarn mod item) `thenRn_` + ifOptRn Opt_WarnMisc (addWarnRn (dodgyImportWarn mod item)) `thenRn_` returnRn [(avail, [availName avail])] Just avail -> returnRn [(avail, [availName avail])] get_item item@(IEThingAbs n) | want_hiding -- hiding( C ) -- Here the 'C' can be a data constructor *or* a type/class - = case catMaybes [check_item item, check_item (IEThingAbs data_n)] of + = case catMaybes [check_item item, check_item (IEVar data_n)] of [] -> bale_out item avails -> returnRn [(a, []) | a <- avails] -- The 'explicits' list is irrelevant when hiding @@ -367,10 +365,10 @@ filterImports mod from (Just (want_hiding, import_items)) total_avails \begin{code} mkEmptyExportAvails :: ModuleName -> ExportAvails -mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyUFM) +mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyNameEnv) -mkExportAvails :: ModuleName -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails -mkExportAvails mod_name unqual_imp gbl_env avails +mkExportAvails :: ModuleName -> Bool -> GlobalRdrEnv -> [AvailInfo] -> [AvailInfo] -> ExportAvails +mkExportAvails mod_name unqual_imp gbl_env hides avails = (mod_avail_env, entity_avail_env) where mod_avail_env = unitFM mod_name unqual_avails @@ -385,7 +383,7 @@ mkExportAvails mod_name unqual_imp gbl_env avails | otherwise = mapMaybe prune avails prune (Avail n) | unqual_in_scope n = Just (Avail n) - prune (Avail n) | otherwise = Nothing + | otherwise = Nothing prune (AvailTC n ns) | null uqs = Nothing | otherwise = Just (AvailTC n uqs) where @@ -393,8 +391,30 @@ mkExportAvails mod_name unqual_imp gbl_env avails unqual_in_scope n = unQualInScope gbl_env n - entity_avail_env = listToUFM [ (name,avail) | avail <- avails, - name <- availNames avail] + + entity_avail_env = mkNameEnv ([ (availName avail,avail) | avail <- effective_avails ] ++ + -- sigh - need to have the method/field names in + -- the environment also, so that export lists + -- can be computed precisely (cf. exportsFromAvail) + [ (name,avail) | avail <- effective_avails, + name <- avNames avail ] ) + + avNames (Avail n) = [n] + avNames (AvailTC n ns) = filter (/=n) ns + + -- remove 'hides' names from the avail list. + effective_avails = foldl wipeOut avails hides + where + wipeOut as (Avail n) = mapMaybe (delName n) as + wipeOut as (AvailTC n ns) = foldl wipeOut as (map Avail ns) + + delName x a@(Avail n) + | n == x = Nothing + | otherwise = Just a + delName x (AvailTC n ns) + = case (filter (/=x) ns) of + [] -> Nothing + xs -> Just (AvailTC n xs) plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails plusExportAvails (m1, e1) (m2, e2) @@ -488,7 +508,7 @@ exportsFromAvail this_mod (Just export_items) = lookupSrcName global_name_env (ieName ie) `thenRn` \ name -> -- See what's available in the current environment - case lookupUFM entity_avail_env name of { + case lookupNameEnv 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