From 0917c5dbca6baf7ddb53147e4aa41f378e8a1a22 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Tue, 10 Dec 2002 15:27:59 +0000
Subject: [PATCH] [project @ 2002-12-10 15:27:58 by simonpj] Report TH errors
 better in stage 1

---
 ghc/compiler/rename/RnEnv.lhs  |   19 +++++++++++---
 ghc/compiler/rename/RnExpr.lhs |   56 +++++++++++++++++++---------------------
 2 files changed, 43 insertions(+), 32 deletions(-)

diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index 77e02b2..4f2fc94 100644
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -581,19 +581,32 @@ implicitModuleFVs source_fvs
     namesNeededForFlattening		`plusFV`
     ubiquitousNames
 
+
+thProxyName :: NameSet
+mkTemplateHaskellFVs :: NameSet -> NameSet
 	-- This is a bit of a hack.  When we see the Template-Haskell construct
 	--	[| expr |]
 	-- we are going to need lots of the ``smart constructors'' defined in
 	-- the main Template Haskell data type module.  Rather than treat them
 	-- all as free vars at every occurrence site, we just make the Q type
 	-- consructor a free var.... and then use that here to haul in the others
-mkTemplateHaskellFVs source_fvs
+
 #ifdef GHCI
-	-- Only if Template Haskell is enabled
+---------------	Template Haskell enabled --------------
+thProxyName = unitFV qTyConName
+
+mkTemplateHaskellFVs source_fvs
   | qTyConName `elemNameSet` source_fvs = templateHaskellNames
-#endif
   | otherwise			        = emptyFVs
 
+#else
+---------------	Template Haskell disabled --------------
+
+thProxyName 			= emptyFVs
+mkTemplateHaskellFVs source_fvs = emptyFVs
+#endif
+--------------------------------------------------------
+
 -- ubiquitous_names are loaded regardless, because 
 -- they are needed in virtually every program
 ubiquitousNames 
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index b1481e3..e8e3f4f 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -43,9 +43,6 @@ import PrelNames	( hasKey, assertIdKey,
 			  crossPName, zipPName, toPName,
 			  enumFromToPName, enumFromThenToPName, assertErrorName,
 			  negateName, monadNames, mfixName )
-#ifdef GHCI
-import DsMeta		( qTyConName )
-#endif
 import Name		( Name, nameOccName )
 import NameSet
 import UnicodeUtil	( stringToUtf8 )
@@ -227,30 +224,26 @@ rnExpr (HsPar e)
     returnM (HsPar e', fvs_e)
 
 -- Template Haskell extensions
-#ifdef GHCI
-rnExpr (HsBracket br_body loc)
-  = addSrcLoc loc			$
-    checkGHCI (thErr "bracket")		`thenM_`
-    rnBracket br_body			`thenM` \ (body', fvs_e) ->
-    returnM (HsBracket body' loc, fvs_e `addOneFV` qTyConName)
-	-- We use the Q tycon as a proxy to haul in all the smart
-	-- constructors; see the hack in RnIfaces
-
-rnExpr (HsSplice n e loc)
-  = addSrcLoc loc			$
-    checkGHCI (thErr "splice")		`thenM_`
-    newLocalsRn [(n,loc)]		`thenM` \ [n'] ->
-    rnExpr e 				`thenM` \ (e', fvs_e) ->
-    returnM (HsSplice n' e' loc, fvs_e `addOneFV` qTyConName)
-	-- The qTyCon brutally pulls in all the meta stuff
-
-rnExpr (HsReify (Reify flavour name))
-  = checkGHCI (thErr "reify")		`thenM_`
-    lookupGlobalOccRn name		`thenM` \ name' ->
+-- Don't ifdef-GHCI them because we want to fail gracefully
+-- (not with an rnExpr crash) in a stage-1 compiler.
+rnExpr e@(HsBracket br_body loc)
+  = addSrcLoc loc		$
+    checkTH e "bracket"		`thenM_`
+    rnBracket br_body		`thenM` \ (body', fvs_e) ->
+    returnM (HsBracket body' loc, fvs_e `plusFV` thProxyName)
+
+rnExpr e@(HsSplice n splice loc)
+  = addSrcLoc loc		$
+    checkTH e "splice"		`thenM_`
+    newLocalsRn [(n,loc)]	`thenM` \ [n'] ->
+    rnExpr splice 		`thenM` \ (splice', fvs_e) ->
+    returnM (HsSplice n' splice' loc, fvs_e `plusFV` thProxyName)
+
+rnExpr e@(HsReify (Reify flavour name))
+  = checkTH e "reify"		`thenM_`
+    lookupGlobalOccRn name	`thenM` \ name' ->
 	-- For now, we can only reify top-level things
-    returnM (HsReify (Reify flavour name'), mkFVs [name', qTyConName])
-	-- The qTyCon brutally pulls in all the meta stuff
-#endif
+    returnM (HsReify (Reify flavour name'), unitFV name' `plusFV` thProxyName)
 
 rnExpr section@(SectionL expr op)
   = rnExpr expr	 				`thenM` \ (expr', fvs_expr) ->
@@ -917,9 +910,14 @@ doStmtListErr do_or_lc e
 			MDoExpr -> "mdo"
 			other   -> "do"
 
-thErr what
-  = ptext SLIT("Template Haskell") <+> text what <+>  
-    ptext SLIT("illegal in a stage-1 compiler") 
+#ifdef GHCI 
+checkTH e what = returnRn ()	-- OK
+#else
+checkTH e what 	-- Raise an error in a stage-1 compiler
+  = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>  
+	          ptext SLIT("illegal in a stage-1 compiler"),
+	          nest 2 (ppr e)])
+#endif   
 
 badIpBinds binds
   = hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4
-- 
1.7.10.4