Commit 49aae125 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Check arity on default decl for assoc types

Fixes Trac #11136.  We should check arity before
doing tcTyClTyVars, because the latter crahes if
the arity isn't right.
parent d25f8535
......@@ -476,7 +476,7 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name, tcdTyVars = hs_tvs
, tcdCtxt = ctxt, tcdSigs = sigs })
= kcTyClTyVars name hs_tvs $
do { _ <- tcHsContext ctxt
; mapM_ (wrapLocM kc_sig) sigs }
; mapM_ (wrapLocM kc_sig) sigs }
where
kc_sig (TypeSig _ op_ty _) = discardResult (tcHsLiftedType op_ty)
kc_sig (GenericSig _ op_ty) = discardResult (tcHsLiftedType op_ty)
......@@ -922,19 +922,28 @@ tcDefaultAssocDecl fam_tc [L loc (TyFamEqn { tfe_tycon = L _ tc_name
, tfe_rhs = rhs })]
= setSrcSpan loc $
tcAddFamInstCtxt (ptext (sLit "default type instance")) tc_name $
tcTyClTyVars tc_name hs_tvs $ \ tvs rhs_kind ->
do { traceTc "tcDefaultAssocDecl" (ppr tc_name)
; checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
; let (fam_name, fam_pat_arity, _) = famTyConShape fam_tc
fam_tc_tvs = tyConTyVars fam_tc
-- Kind of family check
; checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
-- Arity check
; ASSERT( fam_name == tc_name )
checkTc (length (hsQTvBndrs hs_tvs) == fam_pat_arity)
(wrongNumberOfParmsErr fam_pat_arity)
; rhs_ty <- tcCheckLHsType rhs rhs_kind
-- Typecheck RHS
-- NB: the tcTyClTYVars call is here, /after/ the arity check
-- If the arity isn't right, tcTyClTyVars crashes (Trac #11136)
; (tvs, rhs_ty) <- tcTyClTyVars tc_name hs_tvs $ \ tvs rhs_kind ->
do { rhs_ty <- tcCheckLHsType rhs rhs_kind
; return (tvs, rhs_ty) }
; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty
; let fam_tc_tvs = tyConTyVars fam_tc
subst = zipTopTvSubst tvs (mkTyVarTys fam_tc_tvs)
; return ( ASSERT( equalLength fam_tc_tvs tvs )
Just (substTy subst rhs_ty, loc) ) }
; let subst = ASSERT( equalLength tvs fam_tc_tvs )
zipTopTvSubst tvs (mkTyVarTys fam_tc_tvs)
; return ( Just (substTy subst rhs_ty, loc) ) }
-- We check for well-formedness and validity later, in checkValidClass
-------------------------
......
{-# LANGUAGE TypeFamilies #-}
module T11136 where
class C a where
type D a
type instance D a x = x
T11136.hs:7:3: error:
• Number of parameters must match family declaration; expected 1
• In the default type instance declaration for ‘D’
In the class declaration for ‘C’
......@@ -138,3 +138,4 @@ test('T9554', normal, compile_fail, [''])
test('T10141', normal, compile_fail, [''])
test('T10817', normal, compile_fail, [''])
test('T10899', normal, compile_fail, [''])
test('T11136', normal, compile_fail, [''])
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