[commit: ghc] master: Look through type synonyms in existential contexts when deriving Functor (8573100)

[git at git.haskell.org]

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

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

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

commit 85731000d8b13476ed3c5bde22af610a27fb00f8
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Sun Jun 18 14:23:43 2017 -0400

    Look through type synonyms in existential contexts when deriving Functor
    
    Summary:
    This amounts to using `exactTyCoVarsOfType` instead of
    `tyCoVarsOfType` in the right place. I also fixed a similar issue for
    `-XDatatypeContexts` while I was in town (but couldn't be bothered to add a
    test for it).
    
    Test Plan: make test TEST=T13813
    
    Reviewers: austin, bgamari, simonpj
    
    Reviewed By: simonpj
    
    Subscribers: simonpj, rwbarton, thomie
    
    GHC Trac Issues: #13813
    
    Differential Revision: https://phabricator.haskell.org/D3635


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

85731000d8b13476ed3c5bde22af610a27fb00f8
 compiler/typecheck/TcDerivUtils.hs                | 18 ++++++++++++++++--
 testsuite/tests/deriving/should_compile/T13813.hs | 13 +++++++++++++
 testsuite/tests/deriving/should_compile/all.T     |  1 +
 3 files changed, 30 insertions(+), 2 deletions(-)

diff --git a/compiler/typecheck/TcDerivUtils.hs b/compiler/typecheck/TcDerivUtils.hs
index 3a662d9..8991407 100644
--- a/compiler/typecheck/TcDerivUtils.hs
+++ b/compiler/typecheck/TcDerivUtils.hs
@@ -512,7 +512,8 @@ cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ rep_tc
     tc_tvs            = tyConTyVars rep_tc
     Just (_, last_tv) = snocView tc_tvs
     bad_stupid_theta  = filter is_bad (tyConStupidTheta rep_tc)
-    is_bad pred       = last_tv `elemVarSet` tyCoVarsOfType pred
+    is_bad pred       = last_tv `elemVarSet` exactTyCoVarsOfType pred
+      -- See Note [Check that the type variable is truly universal]
 
     data_cons = tyConDataCons rep_tc
     check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con)
@@ -524,7 +525,7 @@ cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ rep_tc
                 -- in TcGenFunctor
       | Just tv <- getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con)))
       , tv `elem` dataConUnivTyVars con
-      , not (tv `elemVarSet` tyCoVarsOfTypes (dataConTheta con))
+      , not (tv `elemVarSet` exactTyCoVarsOfTypes (dataConTheta con))
       = IsValid   -- See Note [Check that the type variable is truly universal]
       | otherwise
       = NotValid (badCon con existential)
@@ -666,4 +667,17 @@ As a result, T can have a derived Foldable instance:
     foldr _ z T6       = z
 
 See Note [DeriveFoldable with ExistentialQuantification] in TcGenFunctor.
+
+For Functor and Traversable, we must take care not to let type synonyms
+unfairly reject a type for not being truly universally quantified. An
+example of this is:
+
+    type C (a :: Constraint) b = a
+    data T a b = C (Show a) b => MkT b
+
+Here, the existential context (C (Show a) b) does technically mention the last
+type variable b. But this is OK, because expanding the type synonym C would
+give us the context (Show a), which doesn't mention b. Therefore, we must make
+sure to expand type synonyms before performing this check. Not doing so led to
+Trac #13813.
 -}
diff --git a/testsuite/tests/deriving/should_compile/T13813.hs b/testsuite/tests/deriving/should_compile/T13813.hs
new file mode 100644
index 0000000..e63869c
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T13813.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE StandaloneDeriving #-}
+module T13813 where
+
+import GHC.Exts (Constraint)
+
+type C (a :: Constraint) b = a
+
+data T a b = C (Show a) b => MkT b
+deriving instance Functor (T a)
diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T
index 36476d5..d1615ab 100644
--- a/testsuite/tests/deriving/should_compile/all.T
+++ b/testsuite/tests/deriving/should_compile/all.T
@@ -91,3 +91,4 @@ test('T13297', normal, compile, [''])
 test('T13758', normal, compile, [''])
 test('drv-empty-data', [normalise_errmsg_fun(just_the_deriving)],compile, ['-ddump-deriv -dsuppress-uniques'])
 test('drv-phantom', [normalise_errmsg_fun(just_the_deriving)],compile, ['-ddump-deriv -dsuppress-uniques'])
+test('T13813', normal, compile, [''])