X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=d69d5c040813b7d389509f79cc5694a05422bcae;hb=1f5e55804b97d2b9a77207d568d602ba88d8855d;hp=708f509e57328adce9f2097c23027ede43170161;hpb=599e42c2948811e71607c5167d9345ddd74d83c3;p=ghc-hetmet.git

diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index 708f509..d69d5c0 100644
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -42,7 +42,7 @@ import RdrName		( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
 import HsTypes		( hsTyVarName, replaceTyVarName )
 import HscTypes		( availNames, ModIface(..), FixItem(..), lookupFixity )
 import TcRnMonad
-import Name		( Name, nameIsLocalOrFrom, mkInternalName, 
+import Name		( Name, nameIsLocalOrFrom, mkInternalName, isInternalName,
 			  nameSrcLoc, nameOccName, nameModuleName, nameParent )
 import NameSet
 import OccName		( tcName, isDataOcc, occNameFlavour, reportIfUnused )
@@ -124,10 +124,10 @@ lookupTopBndrRn :: RdrName -> RnM Name
 
 lookupTopBndrRn rdr_name
   | Just name <- isExact_maybe rdr_name
-	-- This is here just to catch the PrelBase defn of (say) [] and similar
-	-- The parser reads the special syntax and returns an Exact RdrName
-	-- But the global_env contains only Qual RdrNames, so we won't
-	-- find it there; instead just get the name via the Orig route
+	-- This is here to catch 
+	--   (a) Exact-name binders created by Template Haskell
+	--   (b) The PrelBase defn of (say) [] and similar, for which
+	--	 the parser reads the special syntax and returns an Exact RdrName
 	--
   	-- We are at a binding site for the name, so check first that it 
 	-- the current module is the correct one; otherwise GHC can get
@@ -135,7 +135,7 @@ lookupTopBndrRn rdr_name
 	--	data T = (,) Int Int
 	-- unless we are in GHC.Tup
   = getModule				`thenM` \ mod -> 
-    checkErr (moduleName mod == nameModuleName name)
+    checkErr (isInternalName name || moduleName mod == nameModuleName name)
 	     (badOrigBinding rdr_name)	`thenM_`
     returnM name
 
@@ -492,29 +492,25 @@ lookupSyntaxNames std_names
 %*********************************************************
 
 \begin{code}
-newLocalsRn :: [(RdrName,SrcLoc)]
-	    -> RnM [Name]
+newLocalsRn :: [(RdrName,SrcLoc)] -> RnM [Name]
 newLocalsRn rdr_names_w_loc
- =  newUniqueSupply 		`thenM` \ us ->
-    let
-	uniqs	   = uniqsFromSupply us
-	names	   = [ mkInternalName uniq (rdrNameOcc rdr_name) loc
-		     | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs
-		     ]
-    in
-    returnM names
-
+  = newUniqueSupply 		`thenM` \ us ->
+    returnM (zipWith mk rdr_names_w_loc (uniqsFromSupply us))
+  where
+    mk (rdr_name, loc) uniq
+	| Just name <- isExact_maybe rdr_name = name
+		-- This happens in code generated by Template Haskell 
+	| otherwise = ASSERT2( isUnqual rdr_name, ppr rdr_name )
+			-- We only bind unqualified names here
+			-- lookupRdrEnv doesn't even attempt to look up a qualified RdrName
+		      mkInternalName uniq (rdrNameOcc rdr_name) loc
 
 bindLocatedLocalsRn :: SDoc	-- Documentation string for error message
 	   	    -> [(RdrName,SrcLoc)]
 	    	    -> ([Name] -> RnM a)
 	    	    -> RnM a
 bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
-  = ASSERT2( all (isUnqual . fst) rdr_names_w_loc, ppr rdr_names_w_loc )
-	-- We only bind unqualified names here
-	-- lookupRdrEnv doesn't even attempt to look up a qualified RdrName
-
- 	-- Check for duplicate names
+  = 	-- Check for duplicate names
     checkDupNames doc_str rdr_names_w_loc	`thenM_`
 
     	-- Warn about shadowing, but only in source modules