From 8fb61d0a36abdaf5e082569c9e4b3e828a79e4fc Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Wed, 29 Dec 1999 12:17:36 +0000
Subject: [PATCH] [project @ 1999-12-29 12:17:36 by simonpj] Fix a renamer bug
that rejected
import M hiding( C )
where C is a constructor.
---
ghc/compiler/rename/RnMonad.lhs | 6 +++
ghc/compiler/rename/RnNames.lhs | 72 ++++++++++++++++++++++-----------
2 files changed, 54 insertions(+), 24 deletions(-)
diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index 99cc7168269e..0d1ffae0e4fe 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 176eca3b3e34..142b36c2f17b 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
--
GitLab