Fix the handling of names in declaration brackets

The handling of top-level names in declaration brackets is a bit tricky.
This commit fixes Trac #977;  test is TH_spliceD2.

The changes are commented in RnExpr.rnBracket and RdrName.hideSomeUnquals

diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs
index e99a41e..8729f47 100644 (file)
--- a/compiler/basicTypes/RdrName.lhs
+++ b/compiler/basicTypes/RdrName.lhs
@@ -29,7 +29,7 @@ module RdrName (
        GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, 
        lookupGlobalRdrEnv, extendGlobalRdrEnv,
        pprGlobalRdrEnv, globalRdrEnvElts,
-       lookupGRE_RdrName, lookupGRE_Name,
+       lookupGRE_RdrName, lookupGRE_Name, hideSomeUnquals,
 
        -- GlobalRdrElt, Provenance, ImportSpec
        GlobalRdrElt(..), isLocalGRE, unQualOK, 
@@ -45,7 +45,7 @@ import Module   ( ModuleName, mkModuleNameFS, Module, moduleName )
 import Name    ( Name, NamedThing(getName), nameModule, nameParent_maybe,
                  nameOccName, isExternalName, nameSrcLoc )
 import Maybes  ( mapCatMaybes )
-import SrcLoc  ( isGoodSrcLoc, isGoodSrcSpan, SrcSpan )
+import SrcLoc  ( isGoodSrcLoc, isGoodSrcSpan, srcLocSpan, SrcSpan )
 import FastString ( FastString )
 import Outputable
 import Util    ( thenCmp )
@@ -428,6 +428,35 @@ plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt
 plusGRE g1 g2
   = GRE { gre_name = gre_name g1,
          gre_prov = gre_prov g1 `plusProv` gre_prov g2 }
+
+hideSomeUnquals :: GlobalRdrEnv -> [OccName] -> GlobalRdrEnv
+-- Hide any unqualified bindings for the specified OccNames
+-- This is used in TH, when renaming a declaration bracket
+--     [d| foo = ... |]
+-- We want unqualified 'foo' in "..." to mean this foo, not
+-- the one from the enclosing module.  But the *qualified* name
+-- from the enclosing moudule must certainly still be avaialable
+--     Seems like 5 times as much work as it deserves!
+hideSomeUnquals rdr_env occs
+  = foldr hide rdr_env occs
+  where
+    hide occ env 
+       | Just gres <- lookupOccEnv env occ = extendOccEnv env occ (map qual_gre gres)
+       | otherwise                         = env
+    qual_gre gre@(GRE { gre_name = name, gre_prov = LocalDef })
+       = GRE { gre_name = name, gre_prov = Imported [imp_spec] }
+       where   -- Local defs get transfomed to (fake) imported things
+         mod = moduleName (nameModule name)
+         imp_spec = ImpSpec { is_item = ImpAll, is_decl = decl_spec }
+         decl_spec = ImpDeclSpec { is_mod = mod, is_as = mod, 
+                                   is_qual = True, 
+                                   is_dloc = srcLocSpan (nameSrcLoc name) }
+
+    qual_gre gre@(GRE { gre_prov = Imported specs })
+       = gre { gre_prov = Imported (map qual_spec specs) }
+
+    qual_spec spec@(ImpSpec { is_decl = decl_spec })
+       = spec { is_decl = decl_spec { is_qual = True } }
 \end{code}
 
 
@@ -529,8 +558,10 @@ pprNameProvenance :: GlobalRdrElt -> SDoc
 -- Print out the place where the name was imported
 pprNameProvenance (GRE {gre_name = name, gre_prov = LocalDef})
   = ptext SLIT("defined at") <+> ppr (nameSrcLoc name)
-pprNameProvenance (GRE {gre_name = name, gre_prov = Imported (why:whys)})
-  = sep [ppr why, nest 2 (ppr_defn (nameSrcLoc name))]
+pprNameProvenance (GRE {gre_name = name, gre_prov = Imported whys})
+  = case whys of
+       (why:whys) -> sep [ppr why, nest 2 (ppr_defn (nameSrcLoc name))]
+       [] -> panic "pprNameProvenance"
 
 -- If we know the exact definition point (which we may do with GHCi)
 -- then show that too.  But not if it's just "imported from X".

diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 99d0767..735bdc3 100644 (file)
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -43,7 +43,7 @@ import Name             ( isTyVarName )
 #endif
 import Name            ( Name, nameOccName, nameIsLocalOrFrom )
 import NameSet
-import RdrName         ( RdrName, emptyGlobalRdrEnv, extendLocalRdrEnv, lookupLocalRdrEnv )
+import RdrName         ( RdrName, emptyGlobalRdrEnv, extendLocalRdrEnv, lookupLocalRdrEnv, hideSomeUnquals )
 import LoadIface       ( loadInterfaceForName )
 import UniqFM          ( isNullUFM )
 import UniqSet         ( emptyUniqSet )
@@ -573,25 +573,26 @@ rnBracket (DecBr group)
        -- confuse the Names for the current module.  
        -- By using a pretend module, thFAKE, we keep them safely out of the way.
 
-       ; names    <- getLocalDeclBinders gbl_env1 group
-       ; rdr_env' <- extendRdrEnvRn emptyGlobalRdrEnv names
-       -- Furthermore, the names in the bracket shouldn't conflict with
-       -- existing top-level names E.g.
+       ; names <- getLocalDeclBinders gbl_env1 group
+
+       ; let new_occs = map nameOccName names
+             trimmed_rdr_env = hideSomeUnquals (tcg_rdr_env gbl_env) new_occs
+
+       ; rdr_env' <- extendRdrEnvRn trimmed_rdr_env names
+       -- In this situation we want to *shadow* top-level bindings.
        --      foo = 1
        --      bar = [d| foo = 1|]
-       -- But both 'foo's get a LocalDef provenance, so we'd get a complaint unless
-       -- we start with an emptyGlobalRdrEnv
-
-       ; setGblEnv (gbl_env { tcg_rdr_env = tcg_rdr_env gbl_env1 `plusOccEnv` rdr_env',
+       -- If we don't shadow, we'll get an ambiguity complaint when we do 
+       -- a lookupTopBndrRn (which uses lookupGreLocalRn) on the binder of the 'foo'
+       --
+       -- Furthermore, arguably if the splice does define foo, that should hide
+       -- any foo's further out
+       --
+       -- The shadowing is acheived by the call to hideSomeUnquals, which removes
+       -- the unqualified bindings of things defined by the bracket
+
+       ; setGblEnv (gbl_env { tcg_rdr_env = rdr_env',
                               tcg_dus = emptyDUs }) $ do
-               -- Notice plusOccEnv, not plusGlobalRdrEnv.  In this situation we want
-               -- to *shadow* top-level bindings.  (See the 'foo' example above.)
-               -- If we don't shadow, we'll get an ambiguity complaint when we do 
-               -- a lookupTopBndrRn (which uses lookupGreLocalRn) on the binder of the 'foo'
-               --
-               -- Furthermore, arguably if the splice does define foo, that should hide
-               -- any foo's further out
-               --
                -- The emptyDUs is so that we just collect uses for this group alone
 
        { (tcg_env, group') <- rnSrcDecls group