From d52ec21d7ef5dc077f406cd17e57116b9f83fa18 Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Fri, 23 Mar 2007 11:19:12 +0000
Subject: [PATCH] Emit a decent error message when there is a decl-splice
 inside a decl-bracket

This fixes Trac #1065.  The fix is just to emit a decent error message
rather than crash.  The situation is this:

  f x = ... [d| $(..stuff..);
                f x = v :: T |] ...

TH wants to rename and typecheck the bracket; but it can't run the
nested splice yet.  That seems hard, because we know nothing about v, T,
which are, presumably bound by the splice.

The original TH paper says this isn't allowed, and now it's checked for
properly (in the parser, in fact) rather than causing a crash.  In the
fullness of time we might want to do something more flexible, but not now.
---
 compiler/parser/Parser.y.pp  |    5 +++--
 compiler/parser/RdrHsSyn.lhs |   21 ++++++++++-----------
 2 files changed, 13 insertions(+), 13 deletions(-)

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index eec6116..abfc258 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -1363,8 +1363,9 @@ aexp2	:: { LHsExpr RdrName }
 	| '[|' exp '|]'         { LL $ HsBracket (ExpBr $2) }                       
 	| '[t|' ctype '|]'      { LL $ HsBracket (TypBr $2) }                       
 	| '[p|' infixexp '|]'   {% checkPattern $2 >>= \p ->
-					   return (LL $ HsBracket (PatBr p)) }
-	| '[d|' cvtopbody '|]'	{ LL $ HsBracket (DecBr (mkGroup $2)) }
+					return (LL $ HsBracket (PatBr p)) }
+	| '[d|' cvtopbody '|]'	{% checkDecBrGroup $2 >>= \g -> 
+					return (LL $ HsBracket (DecBr g)) }
 
 	-- arrow notation extension
 	| '(|' aexp2 cmdargs '|)'	{ LL $ HsArrForm $2 Nothing (reverse $3) }
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index c29f23a..7a6a0e9 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -17,7 +17,7 @@ module RdrHsSyn (
 	cvBindGroup,
         cvBindsAndSigs,
 	cvTopDecls,
-	findSplice, mkGroup,
+	findSplice, checkDecBrGroup,
 
 	-- Stuff to do with Foreign declarations
 	CallConv(..),
@@ -281,14 +281,15 @@ has_args ((L _ (Match args _ _)) : _) = not (null args)
 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
 findSplice ds = addl emptyRdrGroup ds
 
-mkGroup :: [LHsDecl a] -> HsGroup a
-mkGroup ds = addImpDecls emptyRdrGroup ds
-
-addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
--- The decls are imported, and should not have a splice
-addImpDecls group decls = case addl group decls of
-				(group', Nothing) -> group'
-				other		  -> panic "addImpDecls"
+checkDecBrGroup :: [LHsDecl a] -> P (HsGroup a)
+-- Turn the body of a [d| ... |] into a HsGroup
+-- There should be no splices in the "..."
+checkDecBrGroup decls 
+  = case addl emptyRdrGroup decls of
+	(group, Nothing) -> return group
+	(_, Just (SpliceDecl (L loc _), _)) -> 
+		parseError loc "Declaration splices are not permitted inside declaration brackets"
+		-- Why not?  See Section 7.3 of the TH paper.  
 
 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
 	-- This stuff reverses the declarations (again) but it doesn't matter
@@ -309,8 +310,6 @@ add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs})
 	| isClassDecl d = 	
 		let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
 		addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
-	| isFamInstDecl d = 
-	        addl (gp { hs_tyclds = L l d : ts }) ds
 	| otherwise =
 		addl (gp { hs_tyclds = L l d : ts }) ds
 
-- 
1.7.10.4