From 46e8f199e4d3baffa306a40082fbc2fce67f779f Mon Sep 17 00:00:00 2001
From: Rik Steenkamp <rik@ewps.nl>
Date: Mon, 11 Apr 2016 02:26:06 +0200
Subject: [PATCH] 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
---
 compiler/typecheck/TcTyClsDecls.hs            | 23 +++++++++++--------
 .../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(-)
 create mode 100644 testsuite/tests/typecheck/should_fail/T11623.hs
 create mode 100644 testsuite/tests/typecheck/should_fail/T11623.stderr

diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 6fff74e4b7..7ad7bb4369 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 0000000000..d55ca47a74
--- /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 0000000000..0f6253f103
--- /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 c1c7818a46..fe40ca29b2 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, [''])
-- 
GitLab