X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnExpr.lhs;h=557e1e4f3b4f7eef3f285ef46466db554043ab86;hb=0f800dc9f3dc695cd06d0fdd7799a52c37241752;hp=ad7ddc522b5129c76f7221065b519fadb85b4941;hpb=a32d3e4da0aceb624c958f02cad7327e17ac94db;p=ghc-hetmet.git

diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index ad7ddc5..557e1e4 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -30,20 +30,19 @@ 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 LoadIface	( loadHomeInterface )
-import UnicodeUtil	( stringToUtf8 )
 import UniqFM		( isNullUFM )
 import UniqSet		( emptyUniqSet )
 import List		( nub )
 import Util		( isSingleton )
 import ListSetOps	( removeDups )
-import Maybes		( fromJust )
+import Maybes		( expectJust )
 import Outputable
 import SrcLoc		( Located(..), unLoc, getLoc, cmpLocated )
 import FastString
@@ -256,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}
 
 %************************************************************************
@@ -528,9 +522,10 @@ rnRbinds str rbinds
 
 \begin{code}
 rnBracket (VarBr n) = do { name <- lookupOccRn n
-			 ; loadHomeInterface msg name	-- Reason: deprecation checking asumes the
-							-- home interface is loaded, and this is the
-							-- only way that is going to happen
+			 ; 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")
@@ -545,17 +540,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 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
@@ -668,7 +678,7 @@ rnStmt ctxt (ParStmt segs) thing_inside
 		     { 	-- Find the Names that are bound by stmts
 		       lcl_env <- getLocalRdrEnv
 		     ; let { rdr_bndrs = collectLStmtsBinders stmts
-		     	   ; bndrs = map ( fromJust
+		     	   ; bndrs = map ( expectJust "rnStmt"
 		     		         . lookupLocalRdrEnv lcl_env
 		     		         . unLoc) rdr_bndrs
 		           ; new_bndrs = nub bndrs ++ bndrs_so_far 
@@ -916,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}
@@ -928,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"))