[commit: ghc] master: Make the tyvars in TH-reified data family instances uniform (b2c38d6)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/b2c38d6b4003d3dda60d15204283da5aab15c2ec/ghc

>---------------------------------------------------------------

commit b2c38d6b4003d3dda60d15204283da5aab15c2ec
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Fri Apr 28 13:24:31 2017 -0400

    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


>---------------------------------------------------------------

b2c38d6b4003d3dda60d15204283da5aab15c2ec
 compiler/typecheck/TcSplice.hs                     | 13 ++++++-----
 testsuite/tests/th/T13618.hs                       | 25 ++++++++++++++++++++++
 .../tests/th/T13618.stdout                         |  0
 testsuite/tests/th/all.T                           |  1 +
 4 files changed, 34 insertions(+), 5 deletions(-)

diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 007f825..1e4ec40 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 0000000..487b5e4
--- /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/libraries/base/tests/IO/IOError002.stdout b/testsuite/tests/th/T13618.stdout
similarity index 100%
copy from libraries/base/tests/IO/IOError002.stdout
copy to testsuite/tests/th/T13618.stdout
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 7c98d13..9dadeb6 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'])