From f4fe9286b499aa991fa5b2ce20f0163966af4b58 Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Wed, 10 Oct 2007 15:02:50 +0000
Subject: [PATCH] Fix Trac #1755; check for stage errors in TH quoted Names

There are a number of situations in which you aren't allowed to use
a quoted Name in a TH program, such as
	\x -> 'x
But we weren't checking for that!  Now we are.

Merge to stable branch.

Test is TH_qname.
---
 compiler/typecheck/TcSplice.lhs |   44 ++++++++++++++++++++++++++++++++-------
 1 file changed, 37 insertions(+), 7 deletions(-)

diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 67c197d..aa4c64c 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -141,18 +141,31 @@ tcBracket brack res_ty
     }
 
 tc_bracket :: HsBracket Name -> TcM TcType
-tc_bracket (VarBr v) 
-  = tcMetaTy nameTyConName 	-- Result type is Var (not Q-monadic)
+tc_bracket (VarBr name) 	-- Note [Quoting names]
+  = do	{ thing <- tcLookup name
+	; case thing of
+    	    AGlobal _ -> return ()
+    	    ATcId { tct_level = bind_lvl }
+		| isExternalName name	-- C.f isExternalName case of
+		-> keepAliveTc name 	--     TcExpr.thBrackId
+		| otherwise
+		-> do { use_stage <- getStage
+		      ; checkTc (thLevel use_stage == bind_lvl)
+				(quotedNameStageErr name) }
+	    other -> pprPanic "th_bracket" (ppr name)
+
+	; tcMetaTy nameTyConName 	-- Result type is Var (not Q-monadic)
+	}
 
 tc_bracket (ExpBr expr) 
-  = newFlexiTyVarTy liftedTypeKind	`thenM` \ any_ty ->
-    tcMonoExpr expr any_ty		`thenM_`
-    tcMetaTy expQTyConName
+  = do	{ any_ty <- newFlexiTyVarTy liftedTypeKind
+	; tcMonoExpr expr any_ty
+	; tcMetaTy expQTyConName }
 	-- Result type is Expr (= Q Exp)
 
 tc_bracket (TypBr typ) 
-  = tcHsSigType ExprSigCtxt typ		`thenM_`
-    tcMetaTy typeQTyConName
+  = do	{ tcHsSigType ExprSigCtxt typ
+	; tcMetaTy typeQTyConName }
 	-- Result type is Type (= Q Typ)
 
 tc_bracket (DecBr decls)
@@ -168,8 +181,25 @@ tc_bracket (DecBr decls)
 
 tc_bracket (PatBr _)
   = failWithTc (ptext SLIT("Tempate Haskell pattern brackets are not supported yet"))
+
+quotedNameStageErr v 
+  = sep [ ptext SLIT("Stage error: the non-top-level quoted name") <+> ppr (VarBr v)
+	, ptext SLIT("must be used at the same stage at which is is bound")]
 \end{code}
 
+Note [Quoting names]
+~~~~~~~~~~~~~~~~~~~~
+A quoted name is a bit like a quoted expression, except that we have no 
+cross-stage lifting (c.f. TcExpr.thBrackId).  Examples:
+
+  f 'map	-- OK; also for top-level defns of this module
+
+  \x. f 'x	-- Not ok (whereas \x. f [| x |] might have been ok, by
+		--				 cross-stage lifting
+
+  \y. [| \x. $(f 'y) |]	-- Not ok (same reason)
+
+  [| \x. $(f 'x) |]	-- OK
 
 %************************************************************************
 %*									*
-- 
1.7.10.4