Make the tyvars in TH-reified data family instances uniform
authorRyan Scott <ryan.gl.scott@gmail.com>
Fri, 28 Apr 2017 17:24:31 +0000 (13:24 -0400)
committerBen Gamari <ben@smart-cactus.org>
Fri, 28 Apr 2017 17:24:40 +0000 (13:24 -0400)
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

compiler/typecheck/TcSplice.hs
testsuite/tests/th/T13618.hs [new file with mode: 0644]
testsuite/tests/th/T13618.stdout [new file with mode: 0644]
testsuite/tests/th/all.T

index 007f825..1e4ec40 100644 (file)
@@ -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 (file)
index 0000000..487b5e4
--- /dev/null
@@ -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 (file)
index 0000000..0ca9514
--- /dev/null
@@ -0,0 +1 @@
+True
index 7c98d13..9dadeb6 100644 (file)
@@ -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'])