Commit cd35e860 authored by Rik Steenkamp's avatar Rik Steenkamp Committed by Ben Gamari
Browse files

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

(cherry picked from commit 46e8f199)
parent a4dcdfa5
...@@ -1073,12 +1073,16 @@ proper tcMatchTys here.) -} ...@@ -1073,12 +1073,16 @@ proper tcMatchTys here.) -}
------------------------- -------------------------
kcTyFamInstEqn :: FamTyConShape -> LTyFamInstEqn Name -> TcM () kcTyFamInstEqn :: FamTyConShape -> LTyFamInstEqn Name -> TcM ()
kcTyFamInstEqn fam_tc_shape kcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_,_)
(L loc (TyFamEqn { tfe_pats = pats, tfe_rhs = hs_ty })) (L loc (TyFamEqn { tfe_tycon = L _ eqn_tc_name
, tfe_pats = pats
, tfe_rhs = hs_ty }))
= setSrcSpan loc $ = setSrcSpan loc $
discardResult $ 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 tc_fam_ty_pats fam_tc_shape Nothing -- not an associated type
pats (discardResult . (tcCheckLHsType hs_ty)) pats (discardResult . (tcCheckLHsType hs_ty)) }
tcTyFamInstEqn :: FamTyConShape -> Maybe ClsInfo -> LTyFamInstEqn Name -> TcM CoAxBranch tcTyFamInstEqn :: FamTyConShape -> Maybe ClsInfo -> LTyFamInstEqn Name -> TcM CoAxBranch
-- Needs to be here, not in TcInstDcls, because closed families -- Needs to be here, not in TcInstDcls, because closed families
...@@ -1087,12 +1091,11 @@ tcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_,_) mb_clsinfo ...@@ -1087,12 +1091,11 @@ tcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_,_) mb_clsinfo
(L loc (TyFamEqn { tfe_tycon = L _ eqn_tc_name (L loc (TyFamEqn { tfe_tycon = L _ eqn_tc_name
, tfe_pats = pats , tfe_pats = pats
, tfe_rhs = hs_ty })) , 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)) $ tcFamTyPats fam_tc_shape mb_clsinfo pats (discardResult . (tcCheckLHsType hs_ty)) $
\tvs' pats' res_kind -> \tvs' pats' res_kind ->
do { checkTc (fam_tc_name == eqn_tc_name) do { rhs_ty <- solveEqualities $ tcCheckLHsType hs_ty res_kind
(wrongTyFamName fam_tc_name eqn_tc_name)
; rhs_ty <- solveEqualities $ tcCheckLHsType hs_ty res_kind
; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty
; traceTc "tcTyFamInstEqn" (ppr fam_tc_name <+> pprTvBndrs tvs') ; traceTc "tcTyFamInstEqn" (ppr fam_tc_name <+> pprTvBndrs tvs')
-- don't print out the pats here, as they might be zonked inside the knot -- don't print out the pats here, as they might be zonked inside the knot
...@@ -1209,7 +1212,7 @@ tc_fam_ty_pats (name, _, binders, res_kind) mb_clsinfo ...@@ -1209,7 +1212,7 @@ tc_fam_ty_pats (name, _, binders, res_kind) mb_clsinfo
too_many_args hs_ty n too_many_args hs_ty n
= hang (text "Too many parameters to" <+> ppr name <> colon) = hang (text "Too many parameters to" <+> ppr name <> colon)
2 (vcat [ ppr hs_ty <+> text "is unexpected;" 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") ]) speakNOf (n-1) (text "parameter") ])
-- See Note [tc_fam_ty_pats vs tcFamTyPats] -- See Note [tc_fam_ty_pats vs tcFamTyPats]
......
{-# LANGUAGE TypeFamilies #-}
module T11623 where
type family T where { Maybe T = Int }
T11623.hs:5:23: error:
• Mismatched type name in type family instance.
Expected: T
Actual: Maybe
• In the type family declaration for ‘T’
...@@ -411,6 +411,7 @@ test('T11355', normal, compile_fail, ['']) ...@@ -411,6 +411,7 @@ test('T11355', normal, compile_fail, [''])
test('T11464', normal, compile_fail, ['']) test('T11464', normal, compile_fail, [''])
test('T11563', normal, compile_fail, ['']) test('T11563', normal, compile_fail, [''])
test('T11313', normal, compile_fail, ['']) test('T11313', normal, compile_fail, [''])
test('T11623', normal, compile_fail, [''])
test('T11723', normal, compile_fail, ['']) test('T11723', normal, compile_fail, [''])
test('T11724', normal, compile_fail, ['']) test('T11724', normal, compile_fail, [''])
test('BadUnboxedTuple', normal, compile_fail, ['']) test('BadUnboxedTuple', 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