diff options
| author | Ryan Scott <ryan.gl.scott@gmail.com> | 2017-04-28 13:24:31 -0400 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2017-04-28 13:24:40 -0400 |
| commit | b2c38d6b4003d3dda60d15204283da5aab15c2ec (patch) | |
| tree | 8763cfa9d7840f4ca6fca7bafd5e72ead4c2c2a4 | |
| parent | 69b9b853e3e68191cdfa8aec0e4da966298a2659 (diff) | |
| download | haskell-b2c38d6b4003d3dda60d15204283da5aab15c2ec.tar.gz | |
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
| -rw-r--r-- | compiler/typecheck/TcSplice.hs | 13 | ||||
| -rw-r--r-- | testsuite/tests/th/T13618.hs | 25 | ||||
| -rw-r--r-- | testsuite/tests/th/T13618.stdout | 1 | ||||
| -rw-r--r-- | testsuite/tests/th/all.T | 1 |
4 files changed, 35 insertions, 5 deletions
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 007f825d48..1e4ec4060b 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -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 diff --git a/testsuite/tests/th/T13618.hs b/testsuite/tests/th/T13618.hs new file mode 100644 index 0000000000..487b5e4efc --- /dev/null +++ b/testsuite/tests/th/T13618.hs @@ -0,0 +1,25 @@ +{-# 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) diff --git a/testsuite/tests/th/T13618.stdout b/testsuite/tests/th/T13618.stdout new file mode 100644 index 0000000000..0ca95142bb --- /dev/null +++ b/testsuite/tests/th/T13618.stdout @@ -0,0 +1 @@ +True diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 7c98d13fa7..9dadeb699b 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -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']) |