[commit: ghc] master: Further fixes in RnNames, to make associated type exports work (0cb60ce)
Simon Peyton Jones
simonpj at microsoft.com
Tue Jun 25 12:58:36 CEST 2013
Repository : http://darcs.haskell.org/ghc.git/
On branch : master
https://github.com/ghc/ghc/commit/0cb60cee510ac65b06d9c5b1b3ea8bc9984f6f33
>---------------------------------------------------------------
commit 0cb60cee510ac65b06d9c5b1b3ea8bc9984f6f33
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Tue Jun 25 09:30:27 2013 +0100
Further fixes in RnNames, to make associated type exports work
You ought to be able to say
module M( C( T, foo ) where
class C a where
type T a
foo :: a -> T a
i.e. with T in C's sub-item list. This makes it so.
>---------------------------------------------------------------
compiler/rename/RnNames.lhs | 66 +++++++++++++++++++--------------------------
1 file changed, 27 insertions(+), 39 deletions(-)
diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index 7fee9a8..b45af87 100644
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -596,8 +596,7 @@ filterImports iface decl_spec Nothing
filterImports iface decl_spec (Just (want_hiding, import_items))
= do -- check for errors, convert RdrNames to Names
- opt_typeFamilies <- xoptM Opt_TypeFamilies
- items1 <- mapM (lookup_lie opt_typeFamilies) import_items
+ items1 <- mapM lookup_lie import_items
let items2 :: [(LIE Name, AvailInfo)]
items2 = concat items1
@@ -653,11 +652,11 @@ filterImports iface decl_spec (Just (want_hiding, import_items))
where
mb_success = lookupOccEnv occ_env (rdrNameOcc rdr)
- lookup_lie :: Bool -> LIE RdrName -> TcRn [(LIE Name, AvailInfo)]
- lookup_lie opt_typeFamilies (L loc ieRdr)
- = do (stuff, warns) <- setSrcSpan loc .
- liftM (fromMaybe ([],[])) $
- run_lookup (lookup_ie opt_typeFamilies ieRdr)
+ lookup_lie :: LIE RdrName -> TcRn [(LIE Name, AvailInfo)]
+ lookup_lie (L loc ieRdr)
+ = do (stuff, warns) <- setSrcSpan loc $
+ liftM (fromMaybe ([],[])) $
+ run_lookup (lookup_ie ieRdr)
mapM_ emit_warning warns
return [ (L loc ie, avail) | (ie,avail) <- stuff ]
where
@@ -678,9 +677,6 @@ filterImports iface decl_spec (Just (want_hiding, import_items))
BadImport -> badImportItemErr iface decl_spec ieRdr all_avails
IllegalImport -> illegalImportItemErr
QualImportError rdr -> qualImportItemErr rdr
- TypeItemError children -> typeItemErr
- (head . filter isTyConName $ children)
- (text "in import list")
-- For each import item, we convert its RdrNames to Names,
-- and at the same time construct an AvailInfo corresponding
@@ -692,8 +688,8 @@ filterImports iface decl_spec (Just (want_hiding, import_items))
-- data constructors of an associated family, we need separate
-- AvailInfos for the data constructors and the family (as they have
-- different parents). See the discussion at occ_env.
- lookup_ie :: Bool -> IE RdrName -> IELookupM ([(IE Name, AvailInfo)], [IELookupWarning])
- lookup_ie opt_typeFamilies ie = handle_bad_import $ do
+ lookup_ie :: IE RdrName -> IELookupM ([(IE Name, AvailInfo)], [IELookupWarning])
+ lookup_ie ie = handle_bad_import $ do
case ie of
IEVar n -> do
(name, avail, _) <- lookup_name n
@@ -701,13 +697,9 @@ filterImports iface decl_spec (Just (want_hiding, import_items))
IEThingAll tc -> do
(name, avail@(AvailTC name2 subs), mb_parent) <- lookup_name tc
- let warns
- | null (drop 1 subs)
- = [DodgyImport tc]
- | not (is_qual decl_spec)
- = [MissingImportList]
- | otherwise
- = []
+ let warns | null (drop 1 subs) = [DodgyImport tc]
+ | not (is_qual decl_spec) = [MissingImportList]
+ | otherwise = []
case mb_parent of
-- non-associated ty/cls
Nothing -> return ([(IEThingAll name, avail)], warns)
@@ -735,15 +727,12 @@ filterImports iface decl_spec (Just (want_hiding, import_items))
(name, AvailTC _ subnames, mb_parent) <- lookup_name tc
-- Look up the children in the sub-names of the parent
- let kid_env = mkFsEnv [(occNameFS (nameOccName n), n) | n <- subnames]
- mb_children = map (lookupFsEnv kid_env . occNameFS . rdrNameOcc) ns
+ let mb_children = lookupChildren subnames ns
children <- if any isNothing mb_children
then failLookupWith BadImport
else return (catMaybes mb_children)
- -- check for proper import of type families
- when (not opt_typeFamilies && any isTyConName children) $
- failLookupWith (TypeItemError children)
+
case mb_parent of
-- non-associated ty/cls
Nothing -> return ([(IEThingWith name children,
@@ -780,7 +769,6 @@ data IELookupError
= QualImportError RdrName
| BadImport
| IllegalImport
- | TypeItemError [Name]
failLookupWith :: IELookupError -> IELookupM a
failLookupWith err = Failed err
@@ -865,6 +853,19 @@ mkChildEnv gres = foldr add emptyNameEnv gres
findChildren :: NameEnv [Name] -> Name -> [Name]
findChildren env n = lookupNameEnv env n `orElse` []
+lookupChildren :: [Name] -> [RdrName] -> [Maybe Name]
+-- (lookupChildren all_kids rdr_items) maps each rdr_item to its
+-- corresponding Name all_kids, if the former exists
+-- The matching is done by FastString, not OccName, so that
+-- Cls( meth, AssocTy )
+-- will correctly find AssocTy among the all_kids of Cls, even though
+-- the RdrName for AssocTy may have a (bogus) DataName namespace
+-- (Really the rdr_items should be FastStrings in the first place.)
+lookupChildren all_kids rdr_items
+ = map (lookupFsEnv kid_env . occNameFS . rdrNameOcc) rdr_items
+ where
+ kid_env = mkFsEnv [(occNameFS (nameOccName n), n) | n <- all_kids]
+
-- | Combines 'AvailInfo's from the same family
-- 'avails' may have several items with the same availName
-- E.g import Ix( Ix(..), index )
@@ -1104,20 +1105,12 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod
if isUnboundName name
then return (IEThingWith name [], AvailTC name [name])
else do
- let env = mkOccEnv [ (nameOccName s, s)
- | s <- findChildren kids_env name ]
- mb_names = map (lookupOccEnv env . rdrNameOcc) sub_rdrs
+ let mb_names = lookupChildren (findChildren kids_env name) sub_rdrs
if any isNothing mb_names
then do addErr (exportItemErr ie)
return (IEThingWith name [], AvailTC name [name])
else do let names = catMaybes mb_names
addUsedKids rdr names
- optTyFam <- xoptM Opt_TypeFamilies
- when (not optTyFam && any isTyConName names) $
- addErr (typeItemErr ( head
- . filter isTyConName
- $ names )
- (text "in export list"))
return (IEThingWith name names, AvailTC name (name:names))
lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier
@@ -1619,11 +1612,6 @@ exportItemErr 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") ]
-typeItemErr :: Name -> SDoc -> SDoc
-typeItemErr name wherestr
- = sep [ ptext (sLit "Using 'type' tag on") <+> quotes (ppr name) <+> wherestr,
- ptext (sLit "Use -XTypeFamilies to enable this extension") ]
-
exportClashErr :: GlobalRdrEnv -> Name -> Name -> IE RdrName -> IE RdrName
-> MsgDoc
exportClashErr global_env name1 name2 ie1 ie2
More information about the ghc-commits
mailing list