Commit 5a8ae60e authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu

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

parent 6db0f6fe
......@@ -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)) }
......
......@@ -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
......
......@@ -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'])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment