Commit 3899966e authored by Ryan Scott's avatar Ryan Scott

Fix #16008 with a pinch of addConsistencyConstraints

Summary:
#16008 happened because we forgot to typecheck nullary
associated type family instances in a way that's consistent with the
type variables bound by the parent class. Oops. Easily fixed with a
use of `checkConsistencyConstraints`.

Test Plan: make test TEST=T16008

Reviewers: simonpj, goldfire, bgamari

Reviewed By: goldfire

Subscribers: rwbarton, carter

GHC Trac Issues: #16008

Differential Revision: https://phabricator.haskell.org/D5435
parent 4773b430
...@@ -793,7 +793,10 @@ tcDataFamHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity hs_ctxt hs_pats m_ksi ...@@ -793,7 +793,10 @@ tcDataFamHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity hs_ctxt hs_pats m_ksi
bindImplicitTKBndrs_Q_Skol imp_vars $ bindImplicitTKBndrs_Q_Skol imp_vars $
bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $ bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $
do { stupid_theta <- tcHsContext hs_ctxt do { stupid_theta <- tcHsContext hs_ctxt
; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc mb_clsinfo hs_pats ; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc hs_pats
-- Ensure that the instance is consistent with its
-- parent class
; addConsistencyConstraints mb_clsinfo lhs_ty
; mapM_ (wrapLocM_ kcConDecl) hs_cons ; mapM_ (wrapLocM_ kcConDecl) hs_cons
; res_kind <- tc_kind_sig m_ksig ; res_kind <- tc_kind_sig m_ksig
; lhs_ty <- checkExpectedKindX pp_lhs lhs_ty lhs_kind res_kind ; lhs_ty <- checkExpectedKindX pp_lhs lhs_ty lhs_kind res_kind
......
...@@ -18,7 +18,7 @@ module TcTyClsDecls ( ...@@ -18,7 +18,7 @@ module TcTyClsDecls (
kcConDecl, tcConDecls, dataDeclChecks, checkValidTyCon, kcConDecl, tcConDecls, dataDeclChecks, checkValidTyCon,
tcFamTyPats, tcTyFamInstEqn, tcFamTyPats, tcTyFamInstEqn,
tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt, tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt,
unravelFamInstPats, unravelFamInstPats, addConsistencyConstraints,
wrongKindOfFamily wrongKindOfFamily
) where ) where
...@@ -1741,7 +1741,7 @@ kcTyFamInstEqn tc_fam_tc ...@@ -1741,7 +1741,7 @@ kcTyFamInstEqn tc_fam_tc
; discardResult $ ; discardResult $
bindImplicitTKBndrs_Q_Tv imp_vars $ bindImplicitTKBndrs_Q_Tv imp_vars $
bindExplicitTKBndrs_Q_Tv AnyKind (mb_expl_bndrs `orElse` []) $ bindExplicitTKBndrs_Q_Tv AnyKind (mb_expl_bndrs `orElse` []) $
do { (_, res_kind) <- tcFamTyPats tc_fam_tc NotAssociated hs_pats do { (_, res_kind) <- tcFamTyPats tc_fam_tc hs_pats
; tcCheckLHsType hs_rhs_ty res_kind } ; tcCheckLHsType hs_rhs_ty res_kind }
-- Why "_Tv" here? Consider (Trac #14066 -- Why "_Tv" here? Consider (Trac #14066
-- type family Bar x y where -- type family Bar x y where
...@@ -1870,6 +1870,9 @@ tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty ...@@ -1870,6 +1870,9 @@ tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty
bindImplicitTKBndrs_Q_Skol imp_vars $ bindImplicitTKBndrs_Q_Skol imp_vars $
bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $ bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $
do { (lhs_ty, rhs_kind) <- tc_lhs do { (lhs_ty, rhs_kind) <- tc_lhs
-- Ensure that the instance is consistent with its
-- parent class (#16008)
; addConsistencyConstraints mb_clsinfo lhs_ty
; rhs_ty <- tcCheckLHsType hs_rhs_ty rhs_kind ; rhs_ty <- tcCheckLHsType hs_rhs_ty rhs_kind
; return (lhs_ty, rhs_ty) } ; return (lhs_ty, rhs_ty) }
...@@ -1900,7 +1903,7 @@ tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty ...@@ -1900,7 +1903,7 @@ tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty
(tyConKind fam_tc) (tyConKind fam_tc)
; return (mkTyConApp fam_tc args, rhs_kind) } ; return (mkTyConApp fam_tc args, rhs_kind) }
| otherwise | otherwise
= tcFamTyPats fam_tc mb_clsinfo hs_pats = tcFamTyPats fam_tc hs_pats
{- Note [Apparently-nullary families] {- Note [Apparently-nullary families]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
...@@ -1932,11 +1935,11 @@ Inferred quantifiers always come first. ...@@ -1932,11 +1935,11 @@ Inferred quantifiers always come first.
----------------- -----------------
tcFamTyPats :: TyCon -> AssocInstInfo tcFamTyPats :: TyCon
-> HsTyPats GhcRn -- Patterns -> HsTyPats GhcRn -- Patterns
-> TcM (TcType, TcKind) -- (lhs_type, lhs_kind) -> TcM (TcType, TcKind) -- (lhs_type, lhs_kind)
-- Used for both type and data families -- Used for both type and data families
tcFamTyPats fam_tc mb_clsinfo hs_pats tcFamTyPats fam_tc hs_pats
= do { traceTc "tcFamTyPats {" $ = do { traceTc "tcFamTyPats {" $
vcat [ ppr fam_tc <+> dcolon <+> ppr fam_kind vcat [ ppr fam_tc <+> dcolon <+> ppr fam_kind
, text "arity:" <+> ppr fam_arity , text "arity:" <+> ppr fam_arity
...@@ -1951,9 +1954,6 @@ tcFamTyPats fam_tc mb_clsinfo hs_pats ...@@ -1951,9 +1954,6 @@ tcFamTyPats fam_tc mb_clsinfo hs_pats
vcat [ ppr fam_tc <+> dcolon <+> ppr fam_kind vcat [ ppr fam_tc <+> dcolon <+> ppr fam_kind
, text "res_kind:" <+> ppr res_kind ] , text "res_kind:" <+> ppr res_kind ]
-- Ensure that the instance is consistent its parent class
; addConsistencyConstraints mb_clsinfo fam_app
; return (fam_app, res_kind) } ; return (fam_app, res_kind) }
where where
fam_name = tyConName fam_tc fam_name = tyConName fam_tc
......
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module T16008 where
import Data.Kind
class C k where
type S :: k -> Type
data D :: Type -> Type
data SD :: forall a. D a -> Type
instance C (D a) where
type S = SD
...@@ -655,3 +655,4 @@ test('T15586', normal, compile, ['']) ...@@ -655,3 +655,4 @@ test('T15586', normal, compile, [''])
test('T15368', normal, compile, ['-fdefer-type-errors']) test('T15368', normal, compile, ['-fdefer-type-errors'])
test('T15778', normal, compile, ['']) test('T15778', normal, compile, [''])
test('T14761c', normal, compile, ['']) test('T14761c', normal, compile, [''])
test('T16008', normal, compile, [''])
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