X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnNames.lhs;h=832c92561126305d9bb3c784444a26b5592836c3;hb=06619533d2e402ec10eaec3752c76d310565d0fc;hp=d98dc2aca9d1b3a6477c4ae4e1b5674d74db472a;hpb=39262efa1c066d97547ac72d8bd16a145ac3f359;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index d98dc2a..832c925 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -34,14 +34,15 @@ import PrelMods import PrelInfo ( main_RDR ) import UniqFM ( lookupUFM ) import Bag ( bagToList ) -import Maybes ( maybeToBool ) +import Maybes ( maybeToBool, catMaybes ) import Module ( ModuleName, mkThisModule, pprModuleName, WhereFrom(..) ) import NameSet import Name ( Name, ExportFlag(..), ImportReason(..), Provenance(..), isLocallyDefined, setNameProvenance, nameOccName, getSrcLoc, pprProvenance, getNameProvenance ) -import RdrName ( RdrName, rdrNameOcc, mkRdrQual, mkRdrUnqual, isQual ) +import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual, isQual ) +import OccName ( setOccNameSpace, dataName ) import SrcLoc ( SrcLoc ) import NameSet ( elemNameSet, emptyNameSet ) import Outputable @@ -68,7 +69,7 @@ getGlobalNames :: RdrNameHsModule )) -- Nothing => no need to recompile -getGlobalNames (HsModule this_mod _ exports imports decls mod_loc) +getGlobalNames (HsModule this_mod _ exports imports decls _ mod_loc) = -- These two fix-loops are to get the right -- provenance information into a Name fixRn (\ ~(rec_gbl_env, rec_exported_avails, _) -> @@ -374,6 +375,9 @@ filterImports :: ModuleName -- The module being imported -> 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.) NameSet) -- What was imported explicitly -- Complains if import spec mentions things that the module doesn't export @@ -382,7 +386,7 @@ filterImports mod Nothing imports = returnRn (imports, [], emptyNameSet) filterImports mod (Just (want_hiding, import_items)) avails - = mapMaybeRn check_item import_items `thenRn` \ avails_w_explicits -> + = flatMapRn get_item import_items `thenRn` \ avails_w_explicits -> let (item_avails, explicits_s) = unzip avails_w_explicits explicits = foldl addListToNameSet emptyNameSet explicits_s @@ -403,20 +407,46 @@ filterImports mod (Just (want_hiding, import_items)) avails -- they won't make any difference because naked entities like T -- in an import list map to TcOccs, not VarOccs. - check_item item@(IEModuleContents _) - = addErrRn (badImportItemErr mod item) `thenRn_` - returnRn Nothing + bale_out item = addErrRn (badImportItemErr mod item) `thenRn_` + returnRn [] + + get_item item@(IEModuleContents _) = bale_out item + + get_item item@(IEThingAll _) + = case check_item item of + Nothing -> bale_out item + 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_` + 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 + [] -> bale_out item + avails -> returnRn [(a, []) | a <- avails] + -- The 'explicits' list is irrelevant when hiding + where + data_n = setRdrNameOcc n (setOccNameSpace (rdrNameOcc n) dataName) + + get_item item + = case check_item item of + Nothing -> bale_out item + Just avail -> returnRn [(avail, availNames avail)] + + ok_dotdot_item (AvailTC _ [n]) = False + ok_dotdot_item other = True check_item item | not (maybeToBool maybe_in_import_avails) || not (maybeToBool maybe_filtered_avail) - = addErrRn (badImportItemErr mod item) `thenRn_` - returnRn Nothing - - | dodgy_import = addWarnRn (dodgyImportWarn mod item) `thenRn_` - returnRn (Just (filtered_avail, explicits)) + = Nothing - | otherwise = returnRn (Just (filtered_avail, explicits)) + | otherwise + = Just filtered_avail where wanted_occ = rdrNameOcc (ieName item) @@ -425,20 +455,6 @@ filterImports mod (Just (want_hiding, import_items)) avails Just avail = maybe_in_import_avails maybe_filtered_avail = filterAvail item avail Just filtered_avail = maybe_filtered_avail - explicits | dot_dot = [availName filtered_avail] - | otherwise = availNames filtered_avail - - dot_dot = case item of - IEThingAll _ -> True - other -> False - - dodgy_import = case (item, avail) of - (IEThingAll _, AvailTC _ [n]) -> True - -- This occurs when you import T(..), but - -- only export T abstractly. The single [n] - -- in the AvailTC is the type or class itself - - other -> False \end{code} @@ -608,7 +624,10 @@ exportsFromAvail this_mod (Just export_items) = failWithRn acc (exportItemErr ie) | otherwise -- Phew! It's OK! Now to check the occurrence stuff! - = check_occs ie occs export_avail `thenRn` \ occs' -> + + + = warnCheckRn (ok_item ie avail) (dodgyExportWarn ie) `thenRn_` + check_occs ie occs export_avail `thenRn` \ occs' -> returnRn (mods, occs', add_avail avails export_avail) where @@ -621,6 +640,12 @@ exportsFromAvail this_mod (Just export_items) 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 + add_avail avails avail = addToNameEnv_C plusAvail avails (availName avail) avail check_occs :: RdrNameIE -> ExportOccMap -> AvailInfo -> RnMG ExportOccMap @@ -659,17 +684,20 @@ badImportItemErr mod ie = sep [ptext SLIT("Module"), quotes (pprModuleName mod), ptext SLIT("does not export"), quotes (ppr ie)] -dodgyImportWarn mod (IEThingAll tc) - = sep [ptext SLIT("Module") <+> quotes (pprModuleName mod) - <+> ptext SLIT("exports") <+> quotes (ppr tc), - ptext SLIT("with no constructors/class operations;"), - ptext SLIT("yet it is imported with a (..)")] +dodgyImportWarn mod item = dodgyMsg (ptext SLIT("import")) item +dodgyExportWarn item = dodgyMsg (ptext SLIT("export")) item +dodgyMsg kind item@(IEThingAll tc) + = sep [ ptext SLIT("The") <+> kind <+> ptext SLIT("item") <+> quotes (ppr item), + ptext SLIT("suggests that") <+> quotes (ppr tc) <+> ptext SLIT("has constructor or class methods"), + ptext SLIT("but it has none; it is a type synonym or abstract type or class") ] + modExportErr mod = hsep [ ptext SLIT("Unknown module in export list: module"), quotes (pprModuleName mod)] exportItemErr export_item - = sep [ ptext SLIT("Bad export item"), quotes (ppr export_item)] + = sep [ ptext SLIT("The export item") <+> quotes (ppr export_item), + ptext SLIT("attempts to export constructors or class methods that are not visible here") ] exportClashErr occ_name ie1 ie2 = hsep [ptext SLIT("The export items"), quotes (ppr ie1) @@ -703,5 +731,4 @@ dupFixityDecl rdr_name loc1 loc2 = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name), ptext SLIT("at ") <+> ppr loc1, ptext SLIT("and") <+> ppr loc2] - \end{code}