[commit: ghc] master: Allow associated types as sub-names in an import list (Trac #8011) (e662c62)

[Simon Peyton Jones]

Repository : http://darcs.haskell.org/ghc.git/

On branch  : master

https://github.com/ghc/ghc/commit/e662c62ec8621c66569d74cca7d3a3f648876b8c

>---------------------------------------------------------------

commit e662c62ec8621c66569d74cca7d3a3f648876b8c
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Mon Jun 24 13:10:04 2013 +0100

    Allow associated types as sub-names in an import list (Trac #8011)

>---------------------------------------------------------------

 compiler/rename/RnEnv.lhs   |  9 +++++++--
 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 d3517ce..d73b537 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 4e5672b..7fee9a8 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)