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.

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index eec6116..abfc258 100644 (file)
--- 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 (file)
--- 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