diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2013-06-24 13:10:04 +0100 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2013-06-24 13:10:48 +0100 |
commit | e662c62ec8621c66569d74cca7d3a3f648876b8c (patch) | |
tree | bf274889f2300dd1ebf8bc69d5f7f9f2faa18e19 | |
parent | d2c3630dedc577f7e6eb8e945b05a86992bd5e0a (diff) | |
download | haskell-e662c62ec8621c66569d74cca7d3a3f648876b8c.tar.gz |
Allow associated types as sub-names in an import list (Trac #8011)
-rw-r--r-- | compiler/rename/RnEnv.lhs | 9 | ||||
-rw-r--r-- | compiler/rename/RnNames.lhs | 25 |
2 files changed, 20 insertions, 14 deletions
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index d3517ce52d..d73b537af0 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -25,7 +25,7 @@ module RnEnv ( newLocalBndrRn, newLocalBndrsRn, bindLocalName, bindLocalNames, bindLocalNamesFV, - MiniFixityEnv, emptyFsEnv, extendFsEnv, lookupFsEnv, + MiniFixityEnv, addLocalFixities, bindLocatedLocalsFV, bindLocatedLocalsRn, extendTyVarEnvFVRn, @@ -36,7 +36,10 @@ module RnEnv ( warnUnusedMatches, warnUnusedTopBinds, warnUnusedLocalBinds, dataTcOccs, unknownNameErr, kindSigErr, perhapsForallMsg, - HsDocContext(..), docOfHsDocContext + HsDocContext(..), docOfHsDocContext, + + -- FsEnv + FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv ) where #include "HsVersions.h" @@ -1035,10 +1038,12 @@ type FastStringEnv a = UniqFM a -- Keyed by FastString emptyFsEnv :: FastStringEnv a lookupFsEnv :: FastStringEnv a -> FastString -> Maybe a extendFsEnv :: FastStringEnv a -> FastString -> a -> FastStringEnv a +mkFsEnv :: [(FastString,a)] -> FastStringEnv a emptyFsEnv = emptyUFM lookupFsEnv = lookupUFM extendFsEnv = addToUFM +mkFsEnv = listToUFM -------------------------------- type MiniFixityEnv = FastStringEnv (Located Fixity) diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 4e5672b808..7fee9a822d 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -646,10 +646,16 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) (name, AvailTC name subs, Just parent) combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y) + lookup_name :: RdrName -> IELookupM (Name, AvailInfo, Maybe Name) + lookup_name rdr | isQual rdr = failLookupWith (QualImportError rdr) + | Just succ <- mb_success = return succ + | otherwise = failLookupWith BadImport + 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 . + = do (stuff, warns) <- setSrcSpan loc . liftM (fromMaybe ([],[])) $ run_lookup (lookup_ie opt_typeFamilies ieRdr) mapM_ emit_warning warns @@ -688,13 +694,6 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) -- 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 - let lookup_name rdr - | isQual rdr - = failLookupWith (QualImportError rdr) - | Just nm <- lookupOccEnv occ_env (rdrNameOcc rdr) - = return nm - | otherwise - = failLookupWith BadImport case ie of IEVar n -> do (name, avail, _) <- lookup_name n @@ -734,9 +733,11 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) IEThingWith tc ns -> do (name, AvailTC _ subnames, mb_parent) <- lookup_name tc - let - env = mkOccEnv [(nameOccName s, s) | s <- subnames] - mb_children = map (lookupOccEnv env . rdrNameOcc) ns + + -- 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 + children <- if any isNothing mb_children then failLookupWith BadImport else return (catMaybes mb_children) |