[commit: ghc] master: Check arity on default decl for assoc types (49aae12)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/49aae125686db914a73199d4f789370313892f8f/ghc

>---------------------------------------------------------------

commit 49aae125686db914a73199d4f789370313892f8f
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Nov 27 15:16:17 2015 +0000

    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.


>---------------------------------------------------------------

49aae125686db914a73199d4f789370313892f8f
 compiler/typecheck/TcTyClsDecls.hs                 | 25 +++++++++++++++-------
 .../tests/indexed-types/should_fail/T11136.hs      |  7 ++++++
 .../tests/indexed-types/should_fail/T11136.stderr  |  5 +++++
 testsuite/tests/indexed-types/should_fail/all.T    |  1 +
 4 files changed, 30 insertions(+), 8 deletions(-)

diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 05a79e2..8e42ff2 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 0000000..5e821ee
--- /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 0000000..12a4ec0
--- /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 722a4d3..fa76360 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, [''])