From: simonpj Date: Wed, 29 Dec 1999 12:17:36 +0000 (+0000) Subject: [project @ 1999-12-29 12:17:36 by simonpj] X-Git-Tag: Approximately_9120_patches~5360 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=8fb61d0a36abdaf5e082569c9e4b3e828a79e4fc;p=ghc-hetmet.git [project @ 1999-12-29 12:17:36 by simonpj] Fix a renamer bug that rejected import M hiding( C ) where C is a constructor. --- diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 99cc716..0d1ffae 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -494,6 +494,7 @@ andRn :: (a -> a -> a) -> RnM d a -> RnM d a -> RnM d a mapRn :: (a -> RnM d b) -> [a] -> RnM d [b] mapRn_ :: (a -> RnM d b) -> [a] -> RnM d () mapMaybeRn :: (a -> RnM d (Maybe b)) -> [a] -> RnM d [b] +flatMapRn :: (a -> RnM d [b]) -> [a] -> RnM d [b] sequenceRn :: [RnM d a] -> RnM d [a] foldlRn :: (b -> a -> RnM d b) -> b -> [a] -> RnM d b mapAndUnzipRn :: (a -> RnM d (b,c)) -> [a] -> RnM d ([b],[c]) @@ -546,6 +547,11 @@ mapMaybeRn f (x:xs) = f x `thenRn` \ maybe_r -> case maybe_r of Nothing -> returnRn rs Just r -> returnRn (r:rs) + +flatMapRn f [] = returnRn [] +flatMapRn f (x:xs) = f x `thenRn` \ r -> + flatMapRn f xs `thenRn` \ rs -> + returnRn (r ++ rs) \end{code} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 176eca3..142b36c 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 @@ -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,19 +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 + = Nothing | otherwise - = warnCheckRn (okItem item avail) (dodgyImportWarn mod item) `thenRn_` - returnRn (Just (filtered_avail, explicits)) + = Just filtered_avail where wanted_occ = rdrNameOcc (ieName item) @@ -424,19 +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 - - -okItem (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 -okItem _ _ = True \end{code} @@ -608,7 +626,7 @@ exportsFromAvail this_mod (Just export_items) | otherwise -- Phew! It's OK! Now to check the occurrence stuff! - = warnCheckRn (okItem ie avail) (dodgyExportWarn ie) `thenRn_` + = warnCheckRn (ok_item ie avail) (dodgyExportWarn ie) `thenRn_` check_occs ie occs export_avail `thenRn` \ occs' -> returnRn (mods, occs', add_avail avails export_avail) @@ -622,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