[commit: ghc] wip/rae: Fix #9209, by reporting an error instead of panicking on bad splices. (e860bac)
git at git.haskell.org
git at git.haskell.org
Mon Nov 3 18:51:28 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/rae
Link : http://ghc.haskell.org/trac/ghc/changeset/e860bacd80c385af5a2301f20937046935559ef8/ghc
>---------------------------------------------------------------
commit e860bacd80c385af5a2301f20937046935559ef8
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date: Mon Nov 3 13:49:59 2014 -0500
Fix #9209, by reporting an error instead of panicking on bad splices.
>---------------------------------------------------------------
e860bacd80c385af5a2301f20937046935559ef8
compiler/parser/Parser.y.pp | 15 ++++++------
compiler/parser/RdrHsSyn.lhs | 57 +++++++++++++++++++++++++-------------------
testsuite/tests/th/all.T | 2 +-
3 files changed, 42 insertions(+), 32 deletions(-)
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index e33808d..98468d4 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -684,12 +684,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
@@ -950,7 +950,8 @@ decllist :: { Located (OrdList (LHsDecl RdrName)) }
--
binds :: { Located (HsLocalBinds RdrName) } -- May have implicit parameters
-- No type declarations
- : decllist { L1 (HsValBinds (cvBindGroup (unLoc $1))) }
+ : decllist {% do { val_binds <- cvBindGroup (unLoc $1)
+ ; return (L1 (HsValBinds val_binds)) } }
| '{' dbinds '}' { LL (HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) }
| vocurly dbinds close { L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) }
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index e6969e7..125bfa9 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -127,8 +127,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
@@ -308,36 +308,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 5151fd7..f72bf45 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -336,4 +336,4 @@ test('T8953', normal, compile, ['-v0'])
test('T9084', normal, compile_fail, ['-v0'])
test('T9738', normal, compile, ['-v0'])
test('T9066', normal, compile, ['-v0'])
-test('T9209', expect_broken(9209), compile_fail, ['-v0'])
+test('T9209', normal, compile_fail, ['-v0'])
More information about the ghc-commits
mailing list