[commit: ghc] ghc-8.0: A tiny, outright bug in tcDataFamInstDecl (a885f48)
git at git.haskell.org
git at git.haskell.org
Thu Feb 18 12:03:30 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : ghc-8.0
Link : http://ghc.haskell.org/trac/ghc/changeset/a885f485d3a017658a29b7436f875e7d457b0c81/ghc
>---------------------------------------------------------------
commit a885f485d3a017658a29b7436f875e7d457b0c81
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Mon Feb 15 15:51:50 2016 +0000
A tiny, outright bug in tcDataFamInstDecl
This bug was revealed by Trac #11362. It turns out that in my patch
for Trac #11148 (namely 1160dc5), I failed to turn one occurrence of
tvs' into full_tvs. Sigh. This is tricky stuff and it cost me
several hours to page it back in and figure out what was happening.
The result was a CoAxiom whose lhs had rhs had different kinds. Eeek!
Anyway it's fixed.
I also added an ASSERT, in FamInst.newFamInst, that trips on such
bogus CoAxioms.
(cherry picked from commit e2f7d777bb7e4c176e01e1c4f8184f115253dee0)
>---------------------------------------------------------------
a885f485d3a017658a29b7436f875e7d457b0c81
compiler/typecheck/FamInst.hs | 9 ++++++++-
compiler/typecheck/TcClassDcl.hs | 3 +--
compiler/typecheck/TcInstDcls.hs | 21 +++++++++++----------
testsuite/tests/polykinds/T6137.hs | 21 +++++++++++++++++++--
4 files changed, 39 insertions(+), 15 deletions(-)
diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs
index 3b14829..2ff256d 100644
--- a/compiler/typecheck/FamInst.hs
+++ b/compiler/typecheck/FamInst.hs
@@ -67,7 +67,10 @@ newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcRnIf gbl lcl FamInst
-- Freshen the type variables of the FamInst branches
-- Called from the vectoriser monad too, hence the rather general type
newFamInst flavor axiom@(CoAxiom { co_ax_tc = fam_tc })
- = do { (subst, tvs') <- freshenTyVarBndrs tvs
+ = ASSERT2( tyCoVarsOfTypes lhs `subVarSet` tcv_set, text "lhs" <+> pp_ax )
+ ASSERT2( tyCoVarsOfType rhs `subVarSet` tcv_set, text "rhs" <+> pp_ax )
+ ASSERT2( lhs_kind `eqType` rhs_kind, text "kind" <+> pp_ax $$ ppr lhs_kind $$ ppr rhs_kind )
+ do { (subst, tvs') <- freshenTyVarBndrs tvs
; (subst, cvs') <- freshenCoVarBndrsX subst cvs
; return (FamInst { fi_fam = tyConName fam_tc
, fi_flavor = flavor
@@ -78,6 +81,10 @@ newFamInst flavor axiom@(CoAxiom { co_ax_tc = fam_tc })
, fi_rhs = substTy subst rhs
, fi_axiom = axiom }) }
where
+ lhs_kind = typeKind (mkTyConApp fam_tc lhs)
+ rhs_kind = typeKind rhs
+ tcv_set = mkVarSet (tvs ++ cvs)
+ pp_ax = pprCoAxiom axiom
CoAxBranch { cab_tvs = tvs
, cab_cvs = cvs
, cab_lhs = lhs
diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs
index 9c9d8b5..7fa034c 100644
--- a/compiler/typecheck/TcClassDcl.hs
+++ b/compiler/typecheck/TcClassDcl.hs
@@ -470,8 +470,7 @@ tcATDefault emit_warn loc inst_subst defined_ats (ATI fam_tc defs)
; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty
, pprCoAxiom axiom ])
- ; fam_inst <- ASSERT( tyCoVarsOfType rhs' `subVarSet` tv_set' )
- newFamInst SynFamilyInst axiom
+ ; fam_inst <- newFamInst SynFamilyInst axiom
; return [fam_inst] }
-- No defaults ==> generate a warning
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index e78aab9..d27f350 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -676,7 +676,7 @@ tcDataFamInstDecl mb_clsinfo
-- (obtained from the pats) are at the end (Trac #11148)
orig_res_ty = mkTyConApp fam_tc pats'
- ; (rep_tc, fam_inst) <- fixM $ \ ~(rec_rep_tc, _) ->
+ ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) ->
do { data_cons <- tcConDecls new_or_data
rec_rep_tc
(full_tvs, orig_res_ty) cons
@@ -689,23 +689,23 @@ tcDataFamInstDecl mb_clsinfo
axiom_name eta_tvs [] fam_tc eta_pats
(mkTyConApp rep_tc (mkTyVarTys eta_tvs))
parent = DataFamInstTyCon axiom fam_tc pats'
- kind = mkPiTypesPreferFunTy tvs' liftedTypeKind
-
+ rep_tc_kind = mkPiTypesPreferFunTy full_tvs liftedTypeKind
-- NB: Use the full_tvs from the pats. See bullet toward
-- the end of Note [Data type families] in TyCon
- rep_tc = mkAlgTyCon rep_tc_name kind full_tvs
- (map (const Nominal) full_tvs)
- (fmap unLoc cType) stupid_theta
- tc_rhs parent
- Recursive gadt_syntax
+ rep_tc = mkAlgTyCon rep_tc_name
+ rep_tc_kind
+ full_tvs
+ (map (const Nominal) full_tvs)
+ (fmap unLoc cType) stupid_theta
+ tc_rhs parent
+ Recursive gadt_syntax
-- We always assume that indexed types are recursive. Why?
-- (1) Due to their open nature, we can never be sure that a
-- further instance might not introduce a new recursive
-- dependency. (2) They are always valid loop breakers as
-- they involve a coercion.
- ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom
- ; return (rep_tc, fam_inst) }
+ ; return (rep_tc, axiom) }
-- Remember to check validity; no recursion to worry about here
; checkValidTyCon rep_tc
@@ -717,6 +717,7 @@ tcDataFamInstDecl mb_clsinfo
, di_preds = preds
, di_ctxt = tcMkDataFamInstCtxt decl }
+ ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom
; return (fam_inst, m_deriv_info) } }
where
eta_reduce :: [Type] -> ([Type], [TyVar])
diff --git a/testsuite/tests/polykinds/T6137.hs b/testsuite/tests/polykinds/T6137.hs
index dafe9a2..aac4c1c 100644
--- a/testsuite/tests/polykinds/T6137.hs
+++ b/testsuite/tests/polykinds/T6137.hs
@@ -17,9 +17,26 @@ data Code i o = F (Code (Sum i o) o)
-- An interpretation for `Code` using a data family works:
data family In (f :: Code i o) :: (i -> *) -> (o -> *)
-data instance In (F f) r o where
- MkIn :: In f (Sum1 r (In (F f) r)) o -> In (F f) r o
+data instance In (F f) r x where
+ MkIn :: In f (Sum1 r (In (F f) r)) x -> In (F f) r x
+
+{- data R:InioFrx o i f r x where
+ where MkIn :: forall o i (f :: Code (Sum i o) o) (r :: i -> *) (x :: o).
+ In (Sum i o) o f (Sum1 o i r (In i o ('F i o f) r)) x
+ -> R:InioFrx o i f r x
+
+ So R:InioFrx :: forall o i. Code i o -> (i -> *) -> o -> *
+
+ data family In i o (f :: Code i o) (a :: i -> *) (b :: o)
+
+ axiom D:R:InioFrx0 ::
+ forall o i (f :: Code (Sum i o) o).
+ In i o ('F i o f) = R:InioFrx o i f
+
+
+ D:R:InioFrx0 :: R:InioFrx o i f ~ In i o ('F i o f)
+-}
-- Requires polymorphic recursion
data In' (f :: Code i o) :: (i -> *) -> o -> * where
MkIn' :: In' g (Sum1 r (In' (F g) r)) t -> In' (F g) r t
More information about the ghc-commits
mailing list