From 08a9d7341402232672fcff9062454e6ba1ae8bd1 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Fri, 3 Oct 2008 14:04:23 +0000 Subject: [PATCH] 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. --- compiler/basicTypes/RdrName.lhs | 21 ++++++++----- compiler/iface/IfaceEnv.lhs | 13 ++++++-- compiler/prelude/PrelNames.lhs | 3 +- compiler/rename/RnBinds.lhs | 1 - compiler/rename/RnEnv.lhs | 13 ++++++-- compiler/rename/RnExpr.lhs | 33 ++++++-------------- compiler/rename/RnNames.lhs | 60 +++++++++++++++++++++++-------------- compiler/rename/RnSource.lhs | 13 +++----- compiler/typecheck/TcEnv.lhs | 15 ++++++++-- compiler/typecheck/TcRnDriver.lhs | 7 ++--- 10 files changed, 102 insertions(+), 77 deletions(-) diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index 6b28786..56d4d20 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -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}) diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs index 20d7327..e09ff41 100644 --- a/compiler/iface/IfaceEnv.lhs +++ b/compiler/iface/IfaceEnv.lhs @@ -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 diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 3d1f968..a709abf 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -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") diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 265a038..e2dc69c 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -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 diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index a0d323d..c6468b4 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -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} %********************************************************* diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 942ac2d..df8ccf9 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -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} %************************************************************************ diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 68286b7..8448857 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -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 ------------------------------- diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index bf29b64..67dc2e1 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -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. diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index c93dbe1..259e946 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -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) diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 35f48d0..789ffbc 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -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' -- 1.7.10.4