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.

4 files changed, 30 insertions, 8 deletions

diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 05a79e2b51..8e42ff261f 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -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
 
 -------------------------
diff --git a/testsuite/tests/indexed-types/should_fail/T11136.hs b/testsuite/tests/indexed-types/should_fail/T11136.hs
new file mode 100644
index 0000000000..5e821ee087
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/T11136.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module T11136 where
+
+class C a where
+  type D a
+  type instance D a x = x
diff --git a/testsuite/tests/indexed-types/should_fail/T11136.stderr b/testsuite/tests/indexed-types/should_fail/T11136.stderr
new file mode 100644
index 0000000000..12a4ec0662
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/T11136.stderr
@@ -0,0 +1,5 @@
+

+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’

diff --git a/testsuite/tests/indexed-types/should_fail/all.T b/testsuite/tests/indexed-types/should_fail/all.T
index 722a4d3969..fa763607db 100644
--- a/testsuite/tests/indexed-types/should_fail/all.T
+++ b/testsuite/tests/indexed-types/should_fail/all.T
@@ -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, [''])