X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnExpr.lhs;h=a128c3561f4adce8928604f746a442eb90ec5cf7;hb=5d3051c66796dcf884b052f9e4afc3ed19b9f514;hp=0bf40e64de4d77e4f966c731eed3f719c866277a;hpb=a7ecdf96844404b7bc8273d4ff6d85759278427c;p=ghc-hetmet.git

diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 0bf40e6..a128c35 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -30,13 +30,13 @@ 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 )
+import Name		( Name, nameOccName, nameIsLocalOrFrom )
 import NameSet
 import RdrName		( RdrName, emptyGlobalRdrEnv, extendLocalRdrEnv, lookupLocalRdrEnv )
-import UnicodeUtil	( stringToUtf8 )
+import LoadIface	( loadHomeInterface )
 import UniqFM		( isNullUFM )
 import UniqSet		( emptyUniqSet )
 import List		( nub )
@@ -255,14 +255,9 @@ Since all the symbols are reservedops we can simply reject them.
 We return a (bogus) EWildPat in each case.
 
 \begin{code}
-rnExpr e@EWildPat = addErr (patSynErr e)	`thenM_`
-		    returnM (EWildPat, emptyFVs)
-
-rnExpr e@(EAsPat _ _) = addErr (patSynErr e)	`thenM_`
-		        returnM (EWildPat, emptyFVs)
-
-rnExpr e@(ELazyPat _) = addErr (patSynErr e)	`thenM_`
-		        returnM (EWildPat, emptyFVs)
+rnExpr e@EWildPat      = patSynErr e
+rnExpr e@(EAsPat {})   = patSynErr e
+rnExpr e@(ELazyPat {}) = patSynErr e
 \end{code}
 
 %************************************************************************
@@ -526,29 +521,51 @@ rnRbinds str rbinds
 %************************************************************************
 
 \begin{code}
-rnBracket (VarBr n) = lookupOccRn n		`thenM` \ name -> 
-		      returnM (VarBr name, unitFV name)
-rnBracket (ExpBr e) = rnLExpr e		`thenM` \ (e', fvs) ->
-		      returnM (ExpBr e', fvs)
-rnBracket (PatBr p) = rnLPat p		`thenM` \ (p', fvs) ->
-		      returnM (PatBr p', fvs)
-rnBracket (TypBr t) = rnHsTypeFVs doc t	`thenM` \ (t', fvs) ->
-		      returnM (TypBr t', fvs)
+rnBracket (VarBr n) = do { name <- lookupOccRn n
+			 ; this_mod <- getModule
+			 ; checkM (nameIsLocalOrFrom this_mod name) $	-- Reason: deprecation checking asumes the
+			   do { loadHomeInterface msg name		-- home interface is loaded, and this is the
+			      ; return () }				-- only way that is going to happen
+			 ; returnM (VarBr name, unitFV name) }
+		    where
+		      msg = ptext SLIT("Need interface for Template Haskell quoted Name")
+
+rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
+			 ; return (ExpBr e', fvs) }
+rnBracket (PatBr p) = do { (p', fvs) <- rnLPat p
+			 ; return (PatBr p', fvs) }
+rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
+			 ; return (TypBr t', fvs) }
 		    where
 		      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 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
@@ -909,7 +926,7 @@ mkAssertErrorExpr
   = getSrcSpanM    			`thenM` \ sloc ->
     let
 	expr = HsApp (L sloc (HsVar assertErrorName)) (L sloc (HsLit msg))
-	msg  = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))
+	msg  = HsStringPrim (mkFastString (showSDoc (ppr sloc)))
     in
     returnM (expr, emptyFVs)
 \end{code}
@@ -921,9 +938,9 @@ mkAssertErrorExpr
 %************************************************************************
 
 \begin{code}
-patSynErr e 
-  = sep [ptext SLIT("Pattern syntax in expression context:"),
-	 nest 4 (ppr e)]
+patSynErr e = do { addErr (sep [ptext SLIT("Pattern syntax in expression context:"),
+			 	nest 4 (ppr e)])
+		 ; return (EWildPat, emptyFVs) }
 
 parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglasgow-exts"))