Commit 08a9d734 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Expunge ThFake, cure Trac #2632

This patch fixes a dirty hack (the fake ThFake module), which in turn
was causing Trac #2632.

The new scheme is that the top-level binders in a TH [d| ... |] decl splice
get Internal names.  That breaks a previous invariant that things like
TyCons always have External names, but these TyCons are never long-lived;
they live only long enough to typecheck the TH quotation; the result is
discarded.  So it seems cool.

Nevertheless -- Template Haskell folk: please test your code.  The testsuite
is OK but it's conceivable that I've broken something in TH.  Let's see.
parent 0f853fa1
......@@ -353,6 +353,12 @@ type GlobalRdrEnv = OccEnv [GlobalRdrElt]
--
-- INVARIANT: All the members of the list have distinct
-- 'gre_name' fields; that is, no duplicate Names
--
-- INVARIANT: Imported provenance => Name is an ExternalName
-- However LocalDefs can have an InternalName. This
-- happens only when type-checking a [d| ... |] Template
-- Haskell quotation; see this note in RnNames
-- Note [Top-level Names in Template Haskell decl quotes]
-- | An element of the 'GlobalRdrEnv'
data GlobalRdrElt
......@@ -461,16 +467,17 @@ pickGREs rdr_name gres
pick :: GlobalRdrElt -> Maybe GlobalRdrElt
pick gre@(GRE {gre_prov = LocalDef, gre_name = n}) -- Local def
| rdr_is_unqual = Just gre
| Just (mod,_) <- rdr_is_qual,
mod == moduleName (nameModule n) = Just gre
| otherwise = Nothing
| rdr_is_unqual = Just gre
| Just (mod,_) <- rdr_is_qual -- Qualified name
, Just n_mod <- nameModule_maybe n -- Binder is External
, mod == moduleName n_mod = Just gre
| otherwise = Nothing
pick gre@(GRE {gre_prov = Imported [is]}) -- Single import (efficiency)
| rdr_is_unqual,
not (is_qual (is_decl is)) = Just gre
not (is_qual (is_decl is)) = Just gre
| Just (mod,_) <- rdr_is_qual,
mod == is_as (is_decl is) = Just gre
| otherwise = Nothing
mod == is_as (is_decl is) = Just gre
| otherwise = Nothing
pick gre@(GRE {gre_prov = Imported is}) -- Multiple import
| null filtered_is = Nothing
| otherwise = Just (gre {gre_prov = Imported filtered_is})
......
......@@ -114,9 +114,16 @@ newImplicitBinder :: Name -- Base name
-- For source type/class decls, this is the first occurrence
-- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
newImplicitBinder base_name mk_sys_occ
= newGlobalBinder (nameModule base_name)
(mk_sys_occ (nameOccName base_name))
(nameSrcSpan base_name)
| Just mod <- nameModule_maybe base_name
= newGlobalBinder mod occ loc
| otherwise -- When typechecking a [d| decl bracket |],
-- TH generates types, classes etc with Internal names,
-- so we follow suit for the implicit binders
= do { uniq <- newUnique
; return (mkInternalName uniq occ loc) }
where
occ = mk_sys_occ (nameOccName base_name)
loc = nameSrcSpan base_name
ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]
ifaceExportNames exports = do
......
......@@ -295,9 +295,8 @@ rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation
-- use himself. The z-encoding for ':' is "ZC", so the z-encoded
-- module name still starts with a capital letter, which keeps
-- the z-encoded version consistent.
iNTERACTIVE, thFAKE :: Module
iNTERACTIVE :: Module
iNTERACTIVE = mkMainModule (fsLit ":Interactive")
thFAKE = mkMainModule (fsLit ":THFake")
pRELUDE_NAME, mAIN_NAME :: ModuleName
pRELUDE_NAME = mkModuleNameFS (fsLit "Prelude")
......
......@@ -313,7 +313,6 @@ rnValBindsRHSGen :: (FreeVars -> FreeVars) -- for trimming free var sets
rnValBindsRHSGen trim bound_names (ValBindsIn mbinds sigs) = do
-- rename the sigs
env <- getGblEnv
traceRn (ptext (sLit "Rename sigs") <+> ppr (tcg_rdr_env env))
sigs' <- renameSigs (Just (mkNameSet bound_names)) okBindSig sigs
-- rename the RHSes
binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds
......
......@@ -41,7 +41,7 @@ import HsSyn
import RdrHsSyn ( extractHsTyRdrTyVars )
import RdrName
import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity)
import TcEnv ( tcLookupDataCon )
import TcEnv ( tcLookupDataCon, isBrackStage )
import TcRnMonad
import Name ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName,
nameSrcLoc, nameSrcSpan, nameOccName, nameModule, isExternalName )
......@@ -140,7 +140,16 @@ newTopSrcBinder this_mod (L loc rdr_name)
(addErrAt loc (badQualBndrErr rdr_name))
-- Binders should not be qualified; if they are, and with a different
-- module name, we we get a confusing "M.T is not in scope" error later
; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc }
; stage <- getStage
; if isBrackStage stage then
-- We are inside a TH bracket, so make an *Internal* name
-- See Note [Top-level Names in Template Haskell decl quotes] in RnNames
do { uniq <- newUnique
; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }
else
-- Normal case
newGlobalBinder this_mod (rdrNameOcc rdr_name) loc }
\end{code}
%*********************************************************
......
......@@ -25,13 +25,14 @@ import RnBinds ( rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS,
rnMatchGroup, makeMiniFixityEnv)
import HsSyn
import TcRnMonad
import TcEnv ( thRnBrack )
import RnEnv
import RnTypes ( rnHsTypeFVs,
mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
import RnPat
import DynFlags ( DynFlag(..) )
import BasicTypes ( FixityDirection(..) )
import PrelNames ( thFAKE, hasKey, assertIdKey, assertErrorName,
import PrelNames ( hasKey, assertIdKey, assertErrorName,
loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
negateName, thenMName, bindMName, failMName, groupWithName )
......@@ -594,31 +595,15 @@ rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
rnBracket (DecBr group)
= do { gbl_env <- getGblEnv
; let new_gbl_env = gbl_env { -- Set the module to thFAKE. The top-level names from the bracketed
-- declarations will go into the name cache, and we don't want them to
-- confuse the Names for the current module.
-- By using a pretend module, thFAKE, we keep them safely out of the way.
tcg_mod = thFAKE,
-- The emptyDUs is so that we just collect uses for this group alone
-- in the call to rnSrcDecls below
tcg_dus = emptyDUs }
; setGblEnv new_gbl_env $ do {
-- In this situation we want to *shadow* top-level bindings.
-- foo = 1
-- bar = [d| foo = 1 |]
-- 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 calling rnSrcDecls with True as the shadowing flag
; (tcg_env, group') <- rnSrcDecls True group
; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
-- The emptyDUs is so that we just collect uses for this
-- group alone in the call to rnSrcDecls below
; (tcg_env, group') <- setGblEnv new_gbl_env $
setStage thRnBrack $
rnSrcDecls group
-- Discard the tcg_env; it contains only extra info about fixity
; return (DecBr group', allUses (tcg_dus tcg_env)) } }
; return (DecBr group', allUses (tcg_dus tcg_env)) }
\end{code}
%************************************************************************
......
......@@ -14,6 +14,7 @@ module RnNames (
import DynFlags
import HsSyn
import TcEnv ( isBrackStage )
import RnEnv
import RnHsDoc ( rnHsDoc )
import IfaceEnv ( ifaceExportNames )
......@@ -268,44 +269,57 @@ From the top-level declarations of this module produce
* the ImportAvails
created by its bindings.
Note [Shadowing in extendGlobalRdrEnvRn]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Usually when etending the GlobalRdrEnv we complain if a new binding
duplicates an existing one. By adding the bindings one at a time,
this check also complains if we add two new bindings for the same name.
(Remember that in Template Haskell the duplicates might *already be*
in the GlobalRdrEnv from higher up the module.)
But with a Template Haskell quotation we want to *shadow*:
Note [Top-level Names in Template Haskell decl quotes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider a Template Haskell declaration quotation like this:
module M where
f x = h [d| f = 3 |]
Here the inner binding for 'f' simply shadows the outer one.
And that applies even if the binding for 'f' is in a where-clause,
and hence is in the *local* RdrEnv not the *global* RdrEnv.
When renaming the declarations inside [d| ...|], we treat the
top level binders specially in two ways
Hence the shadowP boolean passed in.
1. We give them an Internal name, not (as usual) an External one.
Otherwise the NameCache gets confused by a second allocation of
M.f. (We used to invent a fake module ThFake to avoid this, but
that had other problems, notably in getting the correct answer for
nameIsLocalOrFrom in lookupFixity. So we now leave tcg_module
unaffected.)
2. We make them *shadow* the outer bindings. If we don't do that,
we'll get a complaint when extending the GlobalRdrEnv, saying that
there are two bindings for 'f'.
This shadowing applies even if the binding for 'f' is in a
where-clause, and hence is in the *local* RdrEnv not the *global*
RdrEnv.
We find out whether we are inside a [d| ... |] by testing the TH
stage. This is a slight hack, because the stage field was really meant for
the type checker, and here we are not interested in the fields of Brack,
hence the error thunks in thRnBrack.
\begin{code}
extendGlobalRdrEnvRn :: Bool -- Note [Shadowing in extendGlobalRdrEnvRn]
-> [AvailInfo]
extendGlobalRdrEnvRn :: [AvailInfo]
-> MiniFixityEnv
-> RnM (TcGblEnv, TcLclEnv)
-- Updates both the GlobalRdrEnv and the FixityEnv
-- We return a new TcLclEnv only becuase we might have to
-- delete some bindings from it; see Note [Shadowing in extendGlobalRdrEnvRn]
-- delete some bindings from it;
-- see Note [Top-level Names in Template Haskell decl quotes]
extendGlobalRdrEnvRn shadowP avails new_fixities
extendGlobalRdrEnvRn avails new_fixities
= do { (gbl_env, lcl_env) <- getEnvs
; stage <- getStage
; let rdr_env = tcg_rdr_env gbl_env
fix_env = tcg_fix_env gbl_env
-- Delete new_occs from global and local envs
-- We are going to shadow them
-- See Note [Shadowing in extendGlobalRdrEnvRn]
-- If we are in a TemplateHaskell decl bracket,
-- we are going to shadow them
-- See Note [Top-level Names in Template Haskell decl quotes]
shadowP = isBrackStage stage
new_occs = map (nameOccName . gre_name) gres
rdr_env1 = hideSomeUnquals rdr_env new_occs
lcl_env1 = lcl_env { tcl_rdr = delListFromOccEnv (tcl_rdr lcl_env) new_occs }
-- Note [Shadowing in extendGlobalRdrEnvRn]
(rdr_env2, lcl_env2) | shadowP = (rdr_env1, lcl_env1)
| otherwise = (rdr_env, lcl_env)
......@@ -941,7 +955,9 @@ isModuleExported implicit_prelude mod (GRE { gre_name = name, gre_prov = prov })
-- every module that imports the Prelude
| otherwise
= case prov of
LocalDef -> moduleName (nameModule name) == mod
LocalDef | Just name_mod <- nameModule_maybe name
-> moduleName name_mod == mod
| otherwise -> False
Imported is -> any unQualSpecOK is && any (qualSpecOK mod) is
-------------------------------
......
......@@ -94,13 +94,8 @@ Checks the @(..)@ etc constraints in the export list.
\begin{code}
-- Brings the binders of the group into scope in the appropriate places;
-- does NOT assume that anything is in scope already
--
-- The Bool determines whether (True) names in the group shadow existing
-- Unquals in the global environment (used in Template Haskell) or
-- (False) whether duplicates are reported as an error
rnSrcDecls :: Bool -> HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
rnSrcDecls shadowP group@(HsGroup {hs_valds = val_decls,
rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
rnSrcDecls group@(HsGroup {hs_valds = val_decls,
hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_derivds = deriv_decls,
......@@ -119,7 +114,7 @@ rnSrcDecls shadowP group@(HsGroup {hs_valds = val_decls,
-- (B) Bring top level binders (and their fixities) into scope,
-- *except* for the value bindings, which get brought in below.
avails <- getLocalNonValBinders group ;
tc_envs <- extendGlobalRdrEnvRn shadowP avails local_fix_env ;
tc_envs <- extendGlobalRdrEnvRn avails local_fix_env ;
setEnvs tc_envs $ do {
failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
......@@ -139,7 +134,7 @@ rnSrcDecls shadowP group@(HsGroup {hs_valds = val_decls,
let { lhs_binders = map unLoc $ collectHsValBinders new_lhs;
lhs_avails = map Avail lhs_binders
} ;
(tcg_env, tcl_env) <- extendGlobalRdrEnvRn shadowP lhs_avails local_fix_env ;
(tcg_env, tcl_env) <- extendGlobalRdrEnvRn lhs_avails local_fix_env ;
setEnvs (tcg_env, tcl_env) $ do {
-- Now everything is in scope, as the remaining renaming assumes.
......
......@@ -39,7 +39,7 @@ module TcEnv(
-- Template Haskell stuff
checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel,
topIdLvl, thTopLevelId,
topIdLvl, thTopLevelId, thRnBrack, isBrackStage,
-- New Ids
newLocalName, newDFunName, newFamInstTyConName,
......@@ -121,8 +121,6 @@ tcLookupGlobal name
Just mod | mod == tcg_mod env -- Names from this module
-> notFound name env -- should be in tcg_type_env
| mod == thFAKE -- Names bound in TH declaration brackets
-> notFound name env -- should be in tcg_env
| otherwise
-> tcImportDecl name -- Go find it in an interface
}}}}}
......@@ -589,6 +587,17 @@ tcMetaTy tc_name = do
t <- tcLookupTyCon tc_name
return (mkTyConApp t [])
thRnBrack :: ThStage
-- Used *only* to indicate that we are inside a TH bracket during renaming
-- Tested by TcEnv.isBrackStage
-- This is a slight hack, used to ensure that
-- * top-level
thRnBrack = Brack (panic "thRnBrack1") (panic "thRnBrack2") (panic "thRnBrack3")
isBrackStage :: ThStage -> Bool
isBrackStage (Brack {}) = True
isBrackStage _other = False
thTopLevelId :: Id -> Bool
-- See Note [What is a top-level Id?] in TcSplice
thTopLevelId id = isGlobalId id || isExternalName (idName id)
......
......@@ -294,8 +294,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
-- (in fact, it might not even need to be in the scope of
-- this tcg_env at all)
avails <- getLocalNonValBinders (mkFakeGroup ldecls) ;
tc_envs <- extendGlobalRdrEnvRn False avails
emptyFsEnv {- no fixity decls -} ;
tc_envs <- extendGlobalRdrEnvRn avails emptyFsEnv {- no fixity decls -} ;
setEnvs tc_envs $ do {
......@@ -747,8 +746,8 @@ monad; it augments it and returns the new TcGblEnv.
rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
-- Fails if there are any errors
rnTopSrcDecls group
= do { -- Rename the source decls (with no shadowing; error on duplicates)
(tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls False group ;
= do { -- Rename the source decls
(tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ;
-- save the renamed syntax, if we want it
let { tcg_env'
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment