X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnNames.lhs;h=24fe3d9333a8cf3e80eceff91529c420d28c7d18;hb=e66018084e22615311828b7a221d5df25cdf09ea;hp=df1925d94503a0c237a661f0ad6280ed9ffbfe28;hpb=f4c599d2460672cdeec7e6b3c4c99bb308a54b67;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index df1925d..24fe3d9 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -5,7 +5,7 @@ \begin{code} module RnNames ( - getGlobalNames, exportsFromAvail + ExportAvails, getGlobalNames, exportsFromAvail ) where #include "HsVersions.h" @@ -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, @@ -25,21 +25,20 @@ import RnEnv import RnMonad import FiniteMap -import PrelNames ( pRELUDE_Name, mAIN_Name, main_RDR_Unqual, isUnboundName ) -import UniqFM ( lookupUFM ) +import PrelNames ( pRELUDE_Name, mAIN_Name, isUnboundName ) 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 Maybes ( maybeToBool, catMaybes ) import ListSetOps ( removeDups ) import Util ( sortLt ) import List ( partition ) @@ -162,13 +161,14 @@ 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 - filterImports imp_mod_name from import_spec avails `thenRn` \ (filtered_avails, hides, explicits) -> + filterImports imp_mod_name from import_spec avails `thenRn` \ (filtered_avails, explicits) -> let unqual_imp = not qual_only -- Maybe want unqualified names @@ -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 deprecs + exports = mkExportAvails qual_mod unqual_imp gbl_env filtered_avails in returnRn (gbl_env, exports) \end{code} @@ -210,9 +210,8 @@ importsFromLocalDecls this_mod decls 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 + gbl_env = mkGlobalRdrEnv mod_name unqual_imp 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 @@ -220,7 +219,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 avails in returnRn (gbl_env, exports) @@ -244,17 +243,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 [] @@ -278,18 +271,13 @@ 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], -- What's imported NameSet) -- What was imported explicitly -- Complains if import spec mentions things that the module doesn't export -- Warns/informs if import spec contains duplicates. filterImports mod from Nothing imports - = returnRn (imports, [], emptyNameSet) + = returnRn (imports, emptyNameSet) filterImports mod from (Just (want_hiding, import_items)) total_avails = flatMapRn get_item import_items `thenRn` \ avails_w_explicits -> @@ -297,13 +285,15 @@ filterImports mod from (Just (want_hiding, import_items)) total_avails (item_avails, explicits_s) = unzip avails_w_explicits explicits = foldl addListToNameSet emptyNameSet explicits_s in - if want_hiding - then - -- All imported; item_avails to be hidden - returnRn (total_avails, item_avails, emptyNameSet) + if want_hiding then + let -- All imported; item_avails to be hidden + hidden = availsToNameSet item_avails + keep n = not (n `elemNameSet` hidden) + in + returnRn (pruneAvails keep total_avails, emptyNameSet) else -- Just item_avails imported; nothing to be hidden - returnRn (item_avails, [], explicits) + returnRn (item_avails, explicits) where import_fm :: FiniteMap OccName AvailInfo import_fm = listToFM [ (nameOccName name, avail) @@ -316,6 +306,12 @@ 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])] + -- Empty list for a bad item. + -- Singleton is typical case. + -- Can have two when we are hiding, and mention C which might be + -- both a class and a data constructor. + -- The [Name] is the list of explicitly-mentioned names get_item item@(IEModuleContents _) = bale_out item get_item item@(IEThingAll _) @@ -324,14 +320,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 @@ -369,40 +365,43 @@ filterImports mod from (Just (want_hiding, import_items)) total_avails %************************************************************************ \begin{code} +type ExportAvails + = (FiniteMap ModuleName Avails, + -- Used to figure out "module M" export specifiers + -- Includes avails only from *unqualified* imports + -- (see 1.4 Report Section 5.1.1) + + AvailEnv) -- All the things that are available. + -- Its domain is all the "main" things; + -- i.e. *excluding* class ops and constructors + -- (which appear inside their parent AvailTC) + mkEmptyExportAvails :: ModuleName -> ExportAvails -mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyUFM) +mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyNameEnv) + +plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails +plusExportAvails (m1, e1) (m2, e2) = (plusFM_C (++) m1 m2, plusAvailEnv e1 e2) mkExportAvails :: ModuleName -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails -mkExportAvails mod_name unqual_imp gbl_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 - -- unqual_avails is the Avails that are visible in *unqualfied* form - -- (1.4 Report, Section 5.1.1) - -- For example, in - -- import T hiding( f ) - -- we delete f from avails + -- unqual_avails is the Avails that are visible in *unqualified* form + -- We need to know this so we know what to export when we see + -- module M ( module P ) where ... + -- Then we must export whatever came from P unqualified. unqual_avails | not unqual_imp = [] -- Short cut when no unqualified imports - | otherwise = mapMaybe prune avails - - prune (Avail n) | unqual_in_scope n = Just (Avail n) - prune (Avail n) | otherwise = Nothing - prune (AvailTC n ns) | null uqs = Nothing - | otherwise = Just (AvailTC n uqs) - where - uqs = filter unqual_in_scope ns - - unqual_in_scope n = unQualInScope gbl_env n - - entity_avail_env = listToUFM [ (name,avail) | avail <- avails, - name <- availNames avail] - -plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails -plusExportAvails (m1, e1) (m2, e2) - = (plusFM_C (++) m1 m2, plusAvailEnv e1 e2) - -- ToDo: wasteful: we do this once for each constructor! + | otherwise = pruneAvails (unQualInScope gbl_env) avails + + entity_avail_env = foldl insert emptyAvailEnv avails + insert env avail = extendNameEnv_C plusAvail env (availName avail) avail + -- 'avails' may have several items with the same availName + -- E.g import Ix( Ix(..), index ) + -- will give Ix(Ix,index,range) and Ix(index) + -- We want to combine these \end{code} @@ -440,25 +439,27 @@ type ExportOccMap = FiniteMap OccName (Name, RdrNameIE) exportsFromAvail :: ModuleName - -> Maybe [RdrNameIE] -- Export spec - -> ExportAvails + -> Maybe [RdrNameIE] -- Export spec + -> FiniteMap ModuleName Avails -- Used for (module M) exports + -> NameEnv AvailInfo -- Domain is every in-scope thing -> GlobalRdrEnv -> RnMG Avails -- Complains if two distinct exports have same OccName -- Warns about identical exports. -- Complains about exports items not in scope -exportsFromAvail this_mod Nothing export_avails global_name_env - = exportsFromAvail this_mod true_exports export_avails global_name_env +exportsFromAvail this_mod Nothing + mod_avail_env entity_avail_env global_name_env + = exportsFromAvail this_mod (Just true_exports) mod_avail_env + entity_avail_env global_name_env where - true_exports = Just $ if this_mod == mAIN_Name - then [IEVar main_RDR_Unqual] - -- export Main.main *only* unless otherwise specified, - else [IEModuleContents this_mod] - -- but for all other modules export everything. + true_exports + | this_mod == mAIN_Name = [] + -- Export nothing; Main.$main is automatically exported + | otherwise = [IEModuleContents this_mod] + -- but for all other modules export everything. exportsFromAvail this_mod (Just export_items) - (mod_avail_env, entity_avail_env) - global_name_env + mod_avail_env entity_avail_env global_name_env = doptRn Opt_WarnDuplicateExports `thenRn` \ warn_dup_exports -> foldlRn (exports_from_item warn_dup_exports) ([], emptyFM, emptyAvailEnv) export_items @@ -491,7 +492,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