[commit: ghc] master: Fix a closed type family error message (46e8f19)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/46e8f199e4d3baffa306a40082fbc2fce67f779f/ghc

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

commit 46e8f199e4d3baffa306a40082fbc2fce67f779f
Author: Rik Steenkamp <rik at ewps.nl>
Date:   Mon Apr 11 02:26:06 2016 +0200

    Fix a closed type family error message
    
    Now we check whether a closed type family's equation is headed with
    the correct type before we kind-check the equation.
    
    Also, instead of "expected only no parameters" we now generate the
    message "expected no parameters".
    
    Fixes #11623.
    
    Reviewers: simonpj, austin, bgamari
    
    Reviewed By: simonpj, bgamari
    
    Subscribers: simonpj, goldfire, thomie
    
    Differential Revision: https://phabricator.haskell.org/D2089
    
    GHC Trac Issues: #11623


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

46e8f199e4d3baffa306a40082fbc2fce67f779f
 compiler/typecheck/TcTyClsDecls.hs                 | 23 ++++++++++++----------
 testsuite/tests/typecheck/should_fail/T11623.hs    |  5 +++++
 .../tests/typecheck/should_fail/T11623.stderr      |  6 ++++++
 testsuite/tests/typecheck/should_fail/all.T        |  1 +
 4 files changed, 25 insertions(+), 10 deletions(-)

diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 6fff74e..7ad7bb4 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -1070,12 +1070,16 @@ proper tcMatchTys here.)  -}
 
 -------------------------
 kcTyFamInstEqn :: FamTyConShape -> LTyFamInstEqn Name -> TcM ()
-kcTyFamInstEqn fam_tc_shape
-    (L loc (TyFamEqn { tfe_pats = pats, tfe_rhs = hs_ty }))
+kcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_,_)
+    (L loc (TyFamEqn { tfe_tycon = L _ eqn_tc_name
+                     , tfe_pats  = pats
+                     , tfe_rhs   = hs_ty }))
   = setSrcSpan loc $
-    discardResult $
-    tc_fam_ty_pats fam_tc_shape Nothing -- not an associated type
-                   pats (discardResult . (tcCheckLHsType hs_ty))
+    do { checkTc (fam_tc_name == eqn_tc_name)
+                 (wrongTyFamName fam_tc_name eqn_tc_name)
+       ; discardResult $
+         tc_fam_ty_pats fam_tc_shape Nothing -- not an associated type
+                        pats (discardResult . (tcCheckLHsType hs_ty)) }
 
 tcTyFamInstEqn :: FamTyConShape -> Maybe ClsInfo -> LTyFamInstEqn Name -> TcM CoAxBranch
 -- Needs to be here, not in TcInstDcls, because closed families
@@ -1084,12 +1088,11 @@ tcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_,_) mb_clsinfo
     (L loc (TyFamEqn { tfe_tycon = L _ eqn_tc_name
                      , tfe_pats  = pats
                      , tfe_rhs   = hs_ty }))
-  = setSrcSpan loc $
+  = ASSERT( fam_tc_name == eqn_tc_name )
+    setSrcSpan loc $
     tcFamTyPats fam_tc_shape mb_clsinfo pats (discardResult . (tcCheckLHsType hs_ty)) $
        \tvs' pats' res_kind ->
-    do { checkTc (fam_tc_name == eqn_tc_name)
-                 (wrongTyFamName fam_tc_name eqn_tc_name)
-       ; rhs_ty <- solveEqualities $ tcCheckLHsType hs_ty res_kind
+    do { rhs_ty <- solveEqualities $ tcCheckLHsType hs_ty res_kind
        ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty
        ; traceTc "tcTyFamInstEqn" (ppr fam_tc_name <+> pprTvBndrs tvs')
           -- don't print out the pats here, as they might be zonked inside the knot
@@ -1206,7 +1209,7 @@ tc_fam_ty_pats (name, _, binders, res_kind) mb_clsinfo
     too_many_args hs_ty n
       = hang (text "Too many parameters to" <+> ppr name <> colon)
            2 (vcat [ ppr hs_ty <+> text "is unexpected;"
-                   , text "expected only" <+>
+                   , text (if n == 1 then "expected" else "expected only") <+>
                      speakNOf (n-1) (text "parameter") ])
 
 -- See Note [tc_fam_ty_pats vs tcFamTyPats]
diff --git a/testsuite/tests/typecheck/should_fail/T11623.hs b/testsuite/tests/typecheck/should_fail/T11623.hs
new file mode 100644
index 0000000..d55ca47
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T11623.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module T11623 where
+
+type family T where { Maybe T = Int }
diff --git a/testsuite/tests/typecheck/should_fail/T11623.stderr b/testsuite/tests/typecheck/should_fail/T11623.stderr
new file mode 100644
index 0000000..0f6253f
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T11623.stderr
@@ -0,0 +1,6 @@
+
+T11623.hs:5:23: error:
+    • Mismatched type name in type family instance.
+        Expected: T
+          Actual: Maybe
+    • In the type family declaration for ‘T’
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index c1c7818..fe40ca2 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -409,6 +409,7 @@ test('T11464', normal, compile_fail, [''])
 test('T11563', normal, compile_fail, [''])
 test('T11541', normal, compile_fail, [''])
 test('T11313', normal, compile_fail, [''])
+test('T11623', normal, compile_fail, [''])
 test('T11723', normal, compile_fail, [''])
 test('T11724', normal, compile_fail, [''])
 test('BadUnboxedTuple', normal, compile_fail, [''])