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

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 ...@@ -476,7 +476,7 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name, tcdTyVars = hs_tvs
, tcdCtxt = ctxt, tcdSigs = sigs }) , tcdCtxt = ctxt, tcdSigs = sigs })
= kcTyClTyVars name hs_tvs $ = kcTyClTyVars name hs_tvs $
do { _ <- tcHsContext ctxt do { _ <- tcHsContext ctxt
; mapM_ (wrapLocM kc_sig) sigs } ; mapM_ (wrapLocM kc_sig) sigs }
where where
kc_sig (TypeSig _ op_ty _) = discardResult (tcHsLiftedType op_ty) kc_sig (TypeSig _ op_ty _) = discardResult (tcHsLiftedType op_ty)
kc_sig (GenericSig _ 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 ...@@ -922,19 +922,28 @@ tcDefaultAssocDecl fam_tc [L loc (TyFamEqn { tfe_tycon = L _ tc_name
, tfe_rhs = rhs })] , tfe_rhs = rhs })]
= setSrcSpan loc $ = setSrcSpan loc $
tcAddFamInstCtxt (ptext (sLit "default type instance")) tc_name $ tcAddFamInstCtxt (ptext (sLit "default type instance")) tc_name $
tcTyClTyVars tc_name hs_tvs $ \ tvs rhs_kind ->
do { traceTc "tcDefaultAssocDecl" (ppr tc_name) do { traceTc "tcDefaultAssocDecl" (ppr tc_name)
; checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
; let (fam_name, fam_pat_arity, _) = famTyConShape 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 ) ; ASSERT( fam_name == tc_name )
checkTc (length (hsQTvBndrs hs_tvs) == fam_pat_arity) checkTc (length (hsQTvBndrs hs_tvs) == fam_pat_arity)
(wrongNumberOfParmsErr 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 ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty
; let fam_tc_tvs = tyConTyVars fam_tc ; let subst = ASSERT( equalLength tvs fam_tc_tvs )
subst = zipTopTvSubst tvs (mkTyVarTys fam_tc_tvs) zipTopTvSubst tvs (mkTyVarTys fam_tc_tvs)
; return ( ASSERT( equalLength fam_tc_tvs tvs ) ; return ( Just (substTy subst rhs_ty, loc) ) }
Just (substTy subst rhs_ty, loc) ) }
-- We check for well-formedness and validity later, in checkValidClass -- 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, ['']) ...@@ -138,3 +138,4 @@ test('T9554', normal, compile_fail, [''])
test('T10141', normal, compile_fail, ['']) test('T10141', normal, compile_fail, [''])
test('T10817', normal, compile_fail, ['']) test('T10817', normal, compile_fail, [''])
test('T10899', 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