Refactor the GlobalRdrEnv, fixing #7672

This patch started innocently enough, by deleting a single
call from rnImportDecl, namely

    let gbl_env = mkGlobalRdrEnv (filterOut from_this_mod gres)

The 'filterOut' makes no sense, and was the cause of #7672.

But that little loose end led to into a twisty maze of little
passages, all alike, which has taken me an unreasonably long
time to straighten out. Happily, I think the result is really
much better.

In particular:

 * INVARIANT 1 of the GlobalRdrEnv type was simply not true:
   we had multiple GlobalRdrElts in a list with the same
   gre_name field. This kludgily implmented one form of
   shadowing.

 * Meanwhile, extendGlobalRdrEnvRn implemented a second form of
   shadowing, by deleting stuff from the GlobalRdrEnv.

 * In turn, much of this shadowing stuff depended on the Names of
   the Ids bound in the GHCi InteractiveContext being Internal
   names, even though the TyCons and suchlike all had External
   Names. Very confusing.

So I have made the following changes

 * I re-established INVARIANT 1 of GlobalRdrEnv.  As a result
   some strange code in RdrName.pickGREs goes away.

 * RnNames.extendGlobalRdrEnvRn now makes one call to deal with
   shadowing, where necessary, and another to extend the
   environment.  It deals separately with duplicate bindings.

   The very complicated RdrName.extendGlobalRdrEnv becomes much
   simpler; we need to export the shadowing function, now called
   RdrName.shadowNames; and we can nuke
   RdrName.findLocalDupsRdrEnv altogether.

   RdrName Note [GlobalRdrEnv shadowing] summarises the shadowing
   story

 * The Names of the Ids bound in the GHCi interactive context are
   now all External.  See Note [Interactively-bound Ids in GHCi]
   in HscTypes.

 * Names for Ids created by the debugger are now made by
   IfaceEnv.newInteractiveBinder.  This fixes a lurking bug which
   was that the debugger was using mkNewUniqueSupply 'I' to make
   uniques, which does NOT guarantee a fresh supply of uniques on
   successive calls.

 * Note [Template Haskell ambiguity] in RnEnv shows that one TH-related
   error is reported lazily (on occurrences) when it might be better
   reported when extending the environment.  In some (but not all) cases
   this was done before; but now it's uniformly at occurrences.  In
   some ways it'd be better to report when extending the environment,
   but it's a tiresome test and the error is rare, so I'm leaving it
   at the lookup site for now, with the above Note.

 * A small thing: RnNames.greAvail becomes RdrName.availFromGRE, where
   it joins the dual RdrName.gresFromAvail.

1 files changed, 25 insertions, 26 deletions

diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index 5b1b33795a..6e891ba798 100644
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -2,14 +2,14 @@
 
 -----------------------------------------------------------------------------
 --
--- GHCi Interactive debugging commands 
+-- GHCi Interactive debugging commands
 --
 -- Pepe Iborra (supported by Google SoC) 2006
 --
 -- ToDo: lots of violation of layering here.  This module should
 -- decide whether it is above the GHC API (import GHC and nothing
 -- else) or below it.
--- 
+--
 -----------------------------------------------------------------------------
 
 module Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where
@@ -20,6 +20,7 @@ import RtClosureInspect
 import GhcMonad
 import HscTypes
 import Id
+import IfaceEnv( newInteractiveBinder )
 import Name
 import Var hiding ( varName )
 import VarSet
@@ -71,7 +72,7 @@ pprintClosureCommand bindThings force str = do
    -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
    go :: GhcMonad m => TvSubst -> Id -> m (TvSubst, Term)
    go subst id = do
-       let id' = id `setIdType` substTy subst (idType id) 
+       let id' = id `setIdType` substTy subst (idType id)
        term_    <- GHC.obtainTermFromId maxBound force id'
        term     <- tidyTermTyVars term_
        term'    <- if bindThings &&
@@ -112,9 +113,9 @@ bindSuspensions t = do
           alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
           availNames   = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames
       availNames_var  <- liftIO $ newIORef availNames
-      (t', stuff)     <- liftIO $ foldTerm (nameSuspensionsAndGetInfos availNames_var) t
+      (t', stuff)     <- liftIO $ foldTerm (nameSuspensionsAndGetInfos hsc_env availNames_var) t
       let (names, tys, hvals) = unzip3 stuff
-      let ids = [ mkVanillaGlobal name ty 
+      let ids = [ mkVanillaGlobal name ty
                 | (name,ty) <- zip names tys]
           new_ic = extendInteractiveContextWithIds ictxt ids
       liftIO $ extendLinkEnv (zip names hvals)
@@ -123,27 +124,27 @@ bindSuspensions t = do
      where
 
 --    Processing suspensions. Give names and recopilate info
-        nameSuspensionsAndGetInfos :: IORef [String] ->
-                                       TermFold (IO (Term, [(Name,Type,HValue)]))
-        nameSuspensionsAndGetInfos freeNames = TermFold
+        nameSuspensionsAndGetInfos :: HscEnv -> IORef [String]
+                                   -> TermFold (IO (Term, [(Name,Type,HValue)]))
+        nameSuspensionsAndGetInfos hsc_env freeNames = TermFold
                       {
-                        fSuspension = doSuspension freeNames
+                        fSuspension = doSuspension hsc_env freeNames
                       , fTerm = \ty dc v tt -> do
                                     tt' <- sequence tt
                                     let (terms,names) = unzip tt'
                                     return (Term ty dc v terms, concat names)
                       , fPrim    = \ty n ->return (Prim ty n,[])
-                      , fNewtypeWrap  = 
-                                \ty dc t -> do 
+                      , fNewtypeWrap  =
+                                \ty dc t -> do
                                     (term, names) <- t
                                     return (NewtypeWrap ty dc term, names)
                       , fRefWrap = \ty t -> do
-                                    (term, names) <- t 
+                                    (term, names) <- t
                                     return (RefWrap ty term, names)
                       }
-        doSuspension freeNames ct ty hval _name = do
+        doSuspension hsc_env freeNames ct ty hval _name = do
           name <- atomicModifyIORef' freeNames (\x->(tail x, head x))
-          n <- newGrimName name
+          n <- newGrimName hsc_env name
           return (Suspension ct ty hval (Just n), [(n,ty,hval)])
 
 
@@ -181,7 +182,7 @@ showTerm term = do
          `gfinally` do
            setSession hsc_env
            GHC.setSessionDynFlags dflags
-  cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} = 
+  cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} =
       cPprShowable prec t{ty=new_ty}
   cPprShowable _ _ = return Nothing
 
@@ -192,26 +193,24 @@ showTerm term = do
 
 
   bindToFreshName hsc_env ty userName = do
-    name <- newGrimName userName
-    let id       = mkVanillaGlobal name ty 
+    name <- newGrimName hsc_env userName
+    let id       = mkVanillaGlobal name ty
         new_ic   = extendInteractiveContextWithIds (hsc_IC hsc_env) [id]
     return (hsc_env {hsc_IC = new_ic }, name)
 
 --    Create new uniques and give them sequentially numbered names
-newGrimName :: MonadIO m => String -> m Name
-newGrimName userName  = do
-    us <- liftIO $ mkSplitUniqSupply 'b'
-    let unique  = uniqFromSupply us
-        occname = mkOccName varName userName
-        name    = mkInternalName unique occname noSrcSpan
-    return name
+newGrimName :: MonadIO m => HscEnv -> String -> m Name
+newGrimName hsc_env userName
+  = liftIO (newInteractiveBinder hsc_env occ noSrcSpan)
+  where
+    occ = mkOccName varName userName
 
 pprTypeAndContents :: GhcMonad m => Id -> m SDoc
 pprTypeAndContents id = do
   dflags  <- GHC.getSessionDynFlags
   let pcontents = gopt Opt_PrintBindContents dflags
       pprdId    = (PprTyThing.pprTyThing . AnId) id
-  if pcontents 
+  if pcontents
     then do
       let depthBound = 100
       -- If the value is an exception, make sure we catch it and
@@ -225,7 +224,7 @@ pprTypeAndContents id = do
     else return pprdId
 
 --------------------------------------------------------------
--- Utils 
+-- Utils
 
 traceOptIf :: GhcMonad m => DumpFlag -> SDoc -> m ()
 traceOptIf flag doc = do