summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorKrzysztof Gogolewski <krzysztof.gogolewski@tweag.io>2021-08-21 00:42:00 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-10-05 03:19:14 -0400
commit298df16d7005a3cead2df1cc7280509ddf7c6c76 (patch)
treecc2d61fa24e649004ceb49f789e2086226795f68
parent5601b9e249661a16f4bfb14958fe10d950e7e589 (diff)
downloadhaskell-298df16d7005a3cead2df1cc7280509ddf7c6c76.tar.gz
Reject type family equation with wrong name (#20260)
We should reject "type family Foo where Bar = ()". This check was done in kcTyFamInstEqn but not in tcTyFamInstEqn. I factored out arity checking, which was duplicated.
-rw-r--r--compiler/GHC/Tc/TyCl.hs49
-rw-r--r--testsuite/tests/typecheck/should_fail/T20260.hs8
-rw-r--r--testsuite/tests/typecheck/should_fail/T20260.stderr6
-rw-r--r--testsuite/tests/typecheck/should_fail/all.T1
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, [''])