From 015aa9723a1e72d7bfe0e82599454bee59f4d472 Mon Sep 17 00:00:00 2001 From: simonpj Date: Wed, 26 Oct 2005 12:05:03 +0000 Subject: [PATCH] [project @ 2005-10-26 12:05:03 by simonpj] MERGE TO STABLE Fix two small Template Haskell bugs. (1) A bug in the renaming of [d| brackets |]. The problem was that when we renamed the bracket we messed up the name cache, because the module was still that of the parent module. Now we set a fake module before renaming it. TH_spliceDecl4 is the test. (2) An expression splice can in principle mention *any* variable, so the renamer really has to assume that it does when doing depdendency analysis. For example f = ... h = ...$(thing "f")... The renamer had better not put 'h' before 'f', else the type checker won't find a defn for 'f' in the type envt. TH_spliceE5 is the test --- ghc/compiler/prelude/PrelNames.lhs | 1 + ghc/compiler/rename/RnExpr.lhs | 35 +++++++++++++++++++++--------- ghc/compiler/rename/RnSource.lhs | 41 ++++++++++++++++++++++++++++++------ 3 files changed, 61 insertions(+), 16 deletions(-) diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index 0d7d558..0d99121 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -274,6 +274,7 @@ rOOT_MAIN = mkModule ":Main" -- Root module for initialisation -- the z-encoded version consistent. iNTERACTIVE = mkModule ":Interactive" +thFAKE = mkModule ":THFake" \end{code} %************************************************************************ diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index c2520806..6c8a18c 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -30,12 +30,12 @@ import RnTypes ( rnHsTypeFVs, rnLPat, rnOverLit, rnPatsAndThen, rnLit, dupFieldErr, checkTupSize ) import DynFlags ( DynFlag(..) ) import BasicTypes ( FixityDirection(..) ) -import PrelNames ( hasKey, assertIdKey, assertErrorName, +import PrelNames ( thFAKE, hasKey, assertIdKey, assertErrorName, loopAName, choiceAName, appAName, arrAName, composeAName, firstAName, negateName, thenMName, bindMName, failMName ) import Name ( Name, nameOccName, nameIsLocalOrFrom ) import NameSet -import RdrName ( RdrName, emptyGlobalRdrEnv, extendLocalRdrEnv, lookupLocalRdrEnv ) +import RdrName ( RdrName, emptyGlobalRdrEnv, plusGlobalRdrEnv, extendLocalRdrEnv, lookupLocalRdrEnv ) import LoadIface ( loadHomeInterface ) import UnicodeUtil ( stringToUtf8 ) import UniqFM ( isNullUFM ) @@ -546,17 +546,32 @@ rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t doc = ptext SLIT("In a Template-Haskell quoted type") rnBracket (DecBr group) = do { gbl_env <- getGblEnv - ; names <- getLocalDeclBinders gbl_env group - ; rdr_env' <- extendRdrEnvRn (tcg_mod gbl_env) emptyGlobalRdrEnv names - ; setGblEnv (gbl_env { tcg_rdr_env = tcg_rdr_env gbl_env `plusOccEnv` rdr_env', + ; let gbl_env1 = gbl_env { tcg_mod = thFAKE } + -- Note the 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. + + ; names <- getLocalDeclBinders gbl_env1 group + ; rdr_env' <- extendRdrEnvRn thFAKE emptyGlobalRdrEnv names + -- Furthermore, the names in the bracket shouldn't conflict with + -- existing top-level names E.g. + -- 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', tcg_dus = emptyDUs }) $ do -- Notice plusOccEnv, not plusGlobalRdrEnv. In this situation we want - -- to *shadow* top-level bindings. E.g. - -- foo = 1 - -- bar = [d| foo = 1|] - -- So we drop down to plusOccEnv. (Perhaps there should be a fn in RdrName.) - -- + -- 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 diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index c113af7..84ff47d 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -15,7 +15,8 @@ module RnSource ( import {-# SOURCE #-} RnExpr( rnLExpr ) import HsSyn -import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv ) +import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, globalRdrEnvElts, + GlobalRdrElt(..), isLocalGRE ) import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars ) import RnHsSyn import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext ) @@ -35,6 +36,7 @@ import Class ( FunDep ) import Name ( Name, nameOccName ) import NameSet import NameEnv +import OccName ( occEnvElts ) import Outputable import SrcLoc ( Located(..), unLoc, getLoc, noLoc ) import DynFlags ( DynFlag(..) ) @@ -661,14 +663,41 @@ rnHsTyvar doc tyvar = lookupOccRn tyvar %* * %********************************************************* +Note [Splices] +~~~~~~~~~~~~~~ +Consider + f = ... + h = ...$(thing "f")... + +The splice can expand into literally anything, so when we do dependency +analysis we must assume that it might mention 'f'. So we simply treat +all locally-defined names as mentioned by any splice. This is terribly +brutal, but I don't see what else to do. For example, it'll mean +that every locally-defined thing will appear to be used, so no unused-binding +warnings. But if we miss the dependency, then we might typecheck 'h' before 'f', +and that will crash the type checker because 'f' isn't in scope. + +Currently, I'm not treating a splice as also mentioning every import, +which is a bit inconsistent -- but there are a lot of them. We might +thereby get some bogus unused-import warnings, but we won't crash the +type checker. Not very satisfactory really. + \begin{code} rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars) rnSplice (HsSplice n expr) - = checkTH expr "splice" `thenM_` - getSrcSpanM `thenM` \ loc -> - newLocalsRn [L loc n] `thenM` \ [n'] -> - rnLExpr expr `thenM` \ (expr', fvs) -> - returnM (HsSplice n' expr', fvs) + = do { checkTH expr "splice" + ; loc <- getSrcSpanM + ; [n'] <- newLocalsRn [L loc n] + ; (expr', fvs) <- rnLExpr expr + + -- Ugh! See Note [Splices] above + ; lcl_rdr <- getLocalRdrEnv + ; gbl_rdr <- getGlobalRdrEnv + ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr, + isLocalGRE gre] + lcl_names = mkNameSet (occEnvElts lcl_rdr) + + ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) } #ifdef GHCI checkTH e what = returnM () -- OK -- 1.7.10.4