Skip to content

Commit

Permalink
Further fixes in RnNames, to make associated type exports work
Browse files Browse the repository at this point in the history
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.
  • Loading branch information
Simon Peyton Jones committed Jun 25, 2013
1 parent e0801a0 commit 0cb60ce
Showing 1 changed file with 27 additions and 39 deletions.
66 changes: 27 additions & 39 deletions compiler/rename/RnNames.lhs
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -692,22 +688,18 @@ 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
return ([(IEVar name, trimAvail avail name)], [])
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)
Expand Down Expand Up @@ -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,
Expand Down Expand Up @@ -780,7 +769,6 @@ data IELookupError
= QualImportError RdrName
| BadImport
| IllegalImport
| TypeItemError [Name]
failLookupWith :: IELookupError -> IELookupM a
failLookupWith err = Failed err
Expand Down Expand Up @@ -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 )
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down

0 comments on commit 0cb60ce

Please sign in to comment.