diff options
| -rw-r--r-- | compiler/GHC/Tc/TyCl.hs | 49 | ||||
| -rw-r--r-- | testsuite/tests/typecheck/should_fail/T20260.hs | 8 | ||||
| -rw-r--r-- | testsuite/tests/typecheck/should_fail/T20260.stderr | 6 | ||||
| -rw-r--r-- | testsuite/tests/typecheck/should_fail/all.T | 1 |
4 files changed, 39 insertions, 25 deletions
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index 08370c2a89..968baad524 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -2985,32 +2985,19 @@ kcTyFamInstEqn tc_fam_tc , text "fam_tc =" <+> ppr tc_fam_tc <+> dcolon <+> ppr (tyConKind tc_fam_tc) , text "feqn_bndrs =" <+> ppr outer_bndrs , text "feqn_pats =" <+> ppr hs_pats ]) - -- this check reports an arity error instead of a kind error; easier for user - ; let vis_pats = numVisibleArgs hs_pats - -- First, check if we're dealing with a closed type family equation, and - -- if so, ensure that each equation's type constructor is for the right - -- type family. E.g. barf on - -- type family F a where { G Int = Bool } - ; checkTc (tc_fam_tc_name == eqn_tc_name) $ - wrongTyFamName tc_fam_tc_name eqn_tc_name - - ; checkTc (vis_pats == vis_arity) $ - wrongNumberOfParmsErr vis_arity + ; checkTyFamInstEqn tc_fam_tc eqn_tc_name hs_pats ; discardResult $ bindOuterFamEqnTKBndrs_Q_Tv outer_bndrs $ do { (_fam_app, res_kind) <- tcFamTyPats tc_fam_tc hs_pats ; tcCheckLHsType hs_rhs_ty (TheKind res_kind) } - -- Why "_Tv" here? Consider (#14066 + -- Why "_Tv" here? Consider (#14066) -- type family Bar x y where -- Bar (x :: a) (y :: b) = Int -- Bar (x :: c) (y :: d) = Bool -- During kind-checking, a,b,c,d should be TyVarTvs and unify appropriately } - where - vis_arity = length (tyConVisibleTyVars tc_fam_tc) - tc_fam_tc_name = getName tc_fam_tc -------------------------- tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn @@ -3019,7 +3006,8 @@ tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn -- (typechecked here) have TyFamInstEqns tcTyFamInstEqn fam_tc mb_clsinfo - (L loc (FamEqn { feqn_bndrs = outer_bndrs + (L loc (FamEqn { feqn_tycon = L _ eqn_tc_name + , feqn_bndrs = outer_bndrs , feqn_pats = hs_pats , feqn_rhs = hs_rhs_ty })) = setSrcSpanA loc $ @@ -3030,15 +3018,8 @@ tcTyFamInstEqn fam_tc mb_clsinfo NotAssociated {} -> empty InClsInst { ai_class = cls } -> text "class" <+> ppr cls <+> pprTyVars (classTyVars cls) ] - -- First, check the arity of visible arguments - -- If we wait until validity checking, we'll get kind errors - -- below when an arity error will be much easier to understand. - -- Note that for closed type families, kcTyFamInstEqn has already - -- checked the arity previously. - ; let vis_arity = length (tyConVisibleTyVars fam_tc) - vis_pats = numVisibleArgs hs_pats - ; checkTc (vis_pats == vis_arity) $ - wrongNumberOfParmsErr vis_arity + ; checkTyFamInstEqn fam_tc eqn_tc_name hs_pats + ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc mb_clsinfo outer_bndrs hs_pats hs_rhs_ty -- Don't print results they may be knot-tied @@ -3047,6 +3028,24 @@ tcTyFamInstEqn fam_tc mb_clsinfo (map (const Nominal) qtvs) (locA loc)) } +checkTyFamInstEqn :: TcTyCon -> Name -> [HsArg tm ty] -> TcM () +checkTyFamInstEqn tc_fam_tc eqn_tc_name hs_pats = + do { -- Ensure that each equation's type constructor is for the right + -- type family. E.g. barf on + -- type family F a where { G Int = Bool } + let tc_fam_tc_name = getName tc_fam_tc + ; checkTc (tc_fam_tc_name == eqn_tc_name) $ + wrongTyFamName tc_fam_tc_name eqn_tc_name + + -- Check the arity of visible arguments + -- If we wait until validity checking, we'll get kind errors + -- below when an arity error will be much easier to understand. + ; let vis_arity = length (tyConVisibleTyVars tc_fam_tc) + vis_pats = numVisibleArgs hs_pats + ; checkTc (vis_pats == vis_arity) $ + wrongNumberOfParmsErr vis_arity + } + {- Note [Instantiating a family tycon] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's possible that kind-checking the result of a family tycon applied to diff --git a/testsuite/tests/typecheck/should_fail/T20260.hs b/testsuite/tests/typecheck/should_fail/T20260.hs new file mode 100644 index 0000000000..1e828f9123 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T20260.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeFamilies, StandaloneKindSignatures #-} +module T20260 where + +data Bar + +type Foo :: * +type family Foo where + Bar = () diff --git a/testsuite/tests/typecheck/should_fail/T20260.stderr b/testsuite/tests/typecheck/should_fail/T20260.stderr new file mode 100644 index 0000000000..574d72163d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T20260.stderr @@ -0,0 +1,6 @@ + +T20260.hs:8:3: error: + • Mismatched type name in type family instance. + Expected: Foo + Actual: Bar + • In the type family declaration for ‘Foo’ diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T index 34ab2f2f7a..37bbc911b9 100644 --- a/testsuite/tests/typecheck/should_fail/all.T +++ b/testsuite/tests/typecheck/should_fail/all.T @@ -637,4 +637,5 @@ test('T19978', normal, compile_fail, ['']) test('T20043', normal, compile_fail, ['']) test('T20122', normal, compile_fail, ['']) test('T20241b', normal, compile_fail, ['']) +test('T20260', normal, compile_fail, ['']) test('OrdErr', normal, compile_fail, ['']) |