Fix #9209, by reporting an error instead of panicking on bad splices.

3 files changed, 42 insertions, 32 deletions

diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index eb528c35dd..4117d06930 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -702,12 +702,12 @@ ty_decl :: { LTyClDecl RdrName }
 
 inst_decl :: { LInstDecl RdrName }
         : 'instance' overlap_pragma inst_type where_inst
-                 { let (binds, sigs, _, ats, adts, _) = cvBindsAndSigs (unLoc $4) in
-                   let cid = ClsInstDecl { cid_poly_ty = $3, cid_binds = binds
-                                         , cid_sigs = sigs, cid_tyfam_insts = ats
-                                         , cid_overlap_mode = $2
-                                         , cid_datafam_insts = adts }
-                   in L (comb3 $1 $3 $4) (ClsInstD { cid_inst = cid }) }
+            {% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (unLoc $4)
+                  ; let cid = ClsInstDecl { cid_poly_ty = $3, cid_binds = binds
+                                          , cid_sigs = sigs, cid_tyfam_insts = ats
+                                          , cid_overlap_mode = $2
+                                          , cid_datafam_insts = adts }
+                  ; return (L (comb3 $1 $3 $4) (ClsInstD { cid_inst = cid })) } }
 
            -- type instance declarations
         | 'type' 'instance' ty_fam_inst_eqn
@@ -986,7 +986,8 @@ decllist :: { Located (OrdList (LHsDecl RdrName)) }
 --
 binds   ::  { Located (HsLocalBinds RdrName) }          -- May have implicit parameters
                                                 -- No type declarations
-        : decllist                      { sL1 $1 (HsValBinds (cvBindGroup (unLoc $1))) }
+        : decllist                      {% do { val_binds <- cvBindGroup (unLoc $1)
+                                              ; return (sL1 $1 (HsValBinds val_binds)) } }
         | '{'            dbinds '}'     { sLL $1 $> (HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) }
         |     vocurly    dbinds close   { L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) }
 
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index e945e43362..e57af70e99 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -125,8 +125,8 @@ mkClassDecl :: SrcSpan
             -> P (LTyClDecl RdrName)
 
 mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
-  = do { let (binds, sigs, ats, at_insts, _, docs) = cvBindsAndSigs (unLoc where_cls)
-             cxt = fromMaybe (noLoc []) mcxt
+  = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs (unLoc where_cls)
+       ; let cxt = fromMaybe (noLoc []) mcxt
        ; (cls, tparams) <- checkTyClHdr tycl_hdr
        ; tyvars <- checkTyVarsP (ptext (sLit "class")) whereDots cls tparams
        ; at_defs <- mapM (eitherToP . mkATDefault) at_insts
@@ -304,36 +304,45 @@ cvTopDecls decls = go (fromOL decls)
     go (d : ds)             = d : go ds
 
 -- Declaration list may only contain value bindings and signatures.
-cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
+cvBindGroup :: OrdList (LHsDecl RdrName) -> P (HsValBinds RdrName)
 cvBindGroup binding
-  = case cvBindsAndSigs binding of
-      (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _)
-         -> ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
-            ValBindsIn mbs sigs
+  = do { (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _) <- cvBindsAndSigs binding
+       ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
+         return $ ValBindsIn mbs sigs }
 
 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
-  -> (LHsBinds RdrName, [LSig RdrName], [LFamilyDecl RdrName]
+  -> P (LHsBinds RdrName, [LSig RdrName], [LFamilyDecl RdrName]
           , [LTyFamInstDecl RdrName], [LDataFamInstDecl RdrName], [LDocDecl])
 -- Input decls contain just value bindings and signatures
 -- and in case of class or instance declarations also
 -- associated type declarations. They might also contain Haddock comments.
-cvBindsAndSigs  fb = go (fromOL fb)
+cvBindsAndSigs fb = go (fromOL fb)
   where
-    go []                  = (emptyBag, [], [], [], [], [])
-    go (L l (SigD s) : ds) = (bs, L l s : ss, ts, tfis, dfis, docs)
-                           where (bs, ss, ts, tfis, dfis, docs) = go ds
-    go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, tfis, dfis, docs)
-                           where (b', ds')    = getMonoBind (L l b) ds
-                                 (bs, ss, ts, tfis, dfis, docs) = go ds'
-    go (L l (TyClD (FamDecl t)) : ds) = (bs, ss, L l t : ts, tfis, dfis, docs)
-                           where (bs, ss, ts, tfis, dfis, docs) = go ds
-    go (L l (InstD (TyFamInstD { tfid_inst = tfi })) : ds) = (bs, ss, ts, L l tfi : tfis, dfis, docs)
-                           where (bs, ss, ts, tfis, dfis, docs) = go ds
-    go (L l (InstD (DataFamInstD { dfid_inst = dfi })) : ds) = (bs, ss, ts, tfis, L l dfi : dfis, docs)
-                           where (bs, ss, ts, tfis, dfis, docs) = go ds
-    go (L l (DocD d) : ds) =  (bs, ss, ts, tfis, dfis, (L l d) : docs)
-                           where (bs, ss, ts, tfis, dfis, docs) = go ds
-    go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d)
+    go []              = return (emptyBag, [], [], [], [], [])
+    go (L l (ValD b) : ds)
+      = do { (bs, ss, ts, tfis, dfis, docs) <- go ds'
+           ; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) }
+      where
+        (b', ds') = getMonoBind (L l b) ds
+    go (L l decl : ds)
+      = do { (bs, ss, ts, tfis, dfis, docs) <- go ds
+           ; case decl of
+               SigD s
+                 -> return (bs, L l s : ss, ts, tfis, dfis, docs)
+               TyClD (FamDecl t)
+                 -> return (bs, ss, L l t : ts, tfis, dfis, docs)
+               InstD (TyFamInstD { tfid_inst = tfi })
+                 -> return (bs, ss, ts, L l tfi : tfis, dfis, docs)
+               InstD (DataFamInstD { dfid_inst = dfi })
+                 -> return (bs, ss, ts, tfis, L l dfi : dfis, docs)
+               DocD d
+                 -> return (bs, ss, ts, tfis, dfis, L l d : docs)
+               SpliceD d
+                 -> parseErrorSDoc l $
+                    hang (text "Declaration splices are allowed only" <+>
+                          text "at the top level:")
+                       2 (ppr d)
+               _ -> pprPanic "cvBindsAndSigs" (ppr decl) }
 
 -----------------------------------------------------------------------------
 -- Group function bindings into equation groups
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index b124fec070..6c7b2e5161 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -342,4 +342,4 @@ test('T9081', normal, compile, ['-v0'])
 test('T9066', normal, compile, ['-v0'])
 test('T8100', normal, compile, ['-v0'])
 test('T9064', normal, compile, ['-v0'])
-test('T9209', expect_broken(9209), compile_fail, ['-v0'])
+test('T9209', normal, compile_fail, ['-v0'])