Commit b2c38d6b authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

Make the tyvars in TH-reified data family instances uniform

It turns out we were using two different sets of type variables when
reifying data family instances in Template Haskell. We were using the
tyvars quantifying over the instance itself for the LHS, but using the
tyvars quantifying over the data family instance constructor for the
RHS. This commit uses the instance tyvars for both the LHS and the RHS,
fixing #13618.

Test Plan: make test TEST=T13618

Reviewers: goldfire, austin, bgamari

Reviewed By: goldfire, bgamari

Subscribers: rwbarton, thomie

GHC Trac Issues: #13618

Differential Revision: https://phabricator.haskell.org/D3505
parent 69b9b853
......@@ -1628,6 +1628,7 @@ reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded
-> FamInst -> TcM TH.Dec
reifyFamilyInstance is_poly_tvs inst@(FamInst { fi_flavor = flavor
, fi_fam = fam
, fi_tvs = fam_tvs
, fi_tys = lhs
, fi_rhs = rhs })
= case flavor of
......@@ -1642,7 +1643,7 @@ reifyFamilyInstance is_poly_tvs inst@(FamInst { fi_flavor = flavor
(TH.TySynEqn annot_th_lhs th_rhs)) }
DataFamilyInst rep_tc ->
do { let tvs = tyConTyVars rep_tc
do { let rep_tvs = tyConTyVars rep_tc
fam' = reifyName fam
-- eta-expand lhs types, because sometimes data/newtype
......@@ -1650,12 +1651,14 @@ reifyFamilyInstance is_poly_tvs inst@(FamInst { fi_flavor = flavor
-- See Note [Eta reduction for data family axioms]
-- in TcInstDcls
(_rep_tc, rep_tc_args) = splitTyConApp rhs
etad_tyvars = dropList rep_tc_args tvs
eta_expanded_lhs = lhs `chkAppend` mkTyVarTys etad_tyvars
dataCons = tyConDataCons rep_tc
etad_tyvars = dropList rep_tc_args rep_tvs
etad_tys = mkTyVarTys etad_tyvars
eta_expanded_tvs = mkTyVarTys fam_tvs `chkAppend` etad_tys
eta_expanded_lhs = lhs `chkAppend` etad_tys
dataCons = tyConDataCons rep_tc
-- see Note [Reifying GADT data constructors]
isGadt = any (not . null . dataConEqSpec) dataCons
; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons
; cons <- mapM (reifyDataCon isGadt eta_expanded_tvs) dataCons
; let types_only = filterOutInvisibleTypes fam_tc eta_expanded_lhs
; th_tys <- reifyTypes types_only
; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys
......
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Main where
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (lift)
data family DF a
data instance DF [a] = DFList a
newtype instance DF (Maybe a) = DFMaybe a
$(return [])
main :: IO ()
main = print
$(do FamilyI (DataFamilyD _ _ _) insts <- reify ''DF
lift $ all (\case DataInstD _ _ [AppT _ (VarT v1)] _
[NormalC _ [(_, VarT v2)]] _
-> v1 == v2
NewtypeInstD _ _ [AppT _ (VarT v1)] _
(NormalC _ [(_, VarT v2)]) _
-> v1 == v2
_ -> error "Not a data or newtype instance")
insts)
......@@ -382,3 +382,4 @@ test('T13098', normal, compile, ['-v0'])
test('T11046', normal, multimod_compile, ['T11046','-v0'])
test('T13366', normal, compile_and_run, ['-lstdc++ -v0'])
test('T13587', expect_broken(13587), compile_and_run, ['-v0'])
test('T13618', normal, compile_and_run, ['-v0'])
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