[commit: ghc] ghc-8.0: Fix #11357. (b1f26af)

[git at git.haskell.org]

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

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/b1f26af9f894eb4c7f237c6c34b23f97d0203f24/ghc

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

commit b1f26af9f894eb4c7f237c6c34b23f97d0203f24
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Tue Mar 15 13:49:15 2016 -0400

    Fix #11357.
    
    We were looking at a data instance tycon for visibility info,
    which is the wrong place to look. Look at the data family tycon
    instead.
    
    Also improved the pretty-printing near there to suppress kind
    arguments when appropriate.
    
    (cherry picked from commit 1eefedf7371778d1721d9af9247c2eff12ae7417)


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

b1f26af9f894eb4c7f237c6c34b23f97d0203f24
 compiler/typecheck/TcDeriv.hs                     |  4 ++--
 compiler/typecheck/TcGenGenerics.hs               | 29 ++++++++++++++++-------
 testsuite/tests/deriving/should_compile/T11357.hs | 10 ++++++++
 testsuite/tests/deriving/should_compile/all.T     |  1 +
 4 files changed, 33 insertions(+), 11 deletions(-)

diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 800d2a5..eb6e13c 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -1240,10 +1240,10 @@ no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>
                      text "must have at least one data constructor"
 
 cond_RepresentableOk :: Condition
-cond_RepresentableOk (_, tc, tc_args) = canDoGenerics tc tc_args
+cond_RepresentableOk (dflags, tc, tc_args) = canDoGenerics dflags tc tc_args
 
 cond_Representable1Ok :: Condition
-cond_Representable1Ok (_, tc, tc_args) = canDoGenerics1 tc tc_args
+cond_Representable1Ok (dflags, tc, tc_args) = canDoGenerics1 dflags tc tc_args
 
 cond_enumOrProduct :: Class -> Condition
 cond_enumOrProduct cls = cond_isEnumeration `orCond`
diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs
index 08b3c9a..0477767 100644
--- a/compiler/typecheck/TcGenGenerics.hs
+++ b/compiler/typecheck/TcGenGenerics.hs
@@ -18,6 +18,7 @@ import Type
 import TcType
 import TcGenDeriv
 import DataCon
+import DynFlags    ( DynFlags, GeneralFlag(Opt_PrintExplicitKinds), gopt )
 import TyCon
 import FamInstEnv       ( FamInst, FamFlavor(..), mkSingleCoAxiom )
 import FamInst
@@ -128,7 +129,7 @@ following constraints are satisfied.
 
 -}
 
-canDoGenerics :: TyCon -> [Type] -> Validity
+canDoGenerics :: DynFlags -> TyCon -> [Type] -> Validity
 -- canDoGenerics rep_tc tc_args determines if Generic/Rep can be derived for a
 -- type expression (rep_tc tc_arg0 tc_arg1 ... tc_argn).
 --
@@ -136,7 +137,7 @@ canDoGenerics :: TyCon -> [Type] -> Validity
 -- care of because canDoGenerics is applied to rep tycons.
 --
 -- It returns Nothing if deriving is possible. It returns (Just reason) if not.
-canDoGenerics tc tc_args
+canDoGenerics dflags tc tc_args
   = mergeErrors (
           -- Check (c) from Note [Requirements for deriving Generic and Rep].
               (if (not (null (tyConStupidTheta tc)))
@@ -146,7 +147,12 @@ canDoGenerics tc tc_args
           --
           -- Data family indices can be instantiated; the `tc_args` here are
           -- the representation tycon args
-              (if (all isTyVarTy (filterOutInvisibleTypes tc tc_args))
+          --
+          -- NB: Use user_tc here. In the case of a data *instance*, the
+          -- user_tc is the family tc, which has the right visibility settings.
+          -- (For a normal datatype, user_tc == tc.) Getting this wrong
+          -- led to #11357.
+              (if (all isTyVarTy (filterOutInvisibleTypes user_tc tc_args))
                 then IsValid
                 else NotValid (tc_name <+> text "must not be instantiated;" <+>
                                text "try deriving `" <> tc_name <+> tc_tys <>
@@ -156,9 +162,14 @@ canDoGenerics tc tc_args
   where
     -- The tc can be a representation tycon. When we want to display it to the
     -- user (in an error message) we should print its parent
-    (tc_name, tc_tys) = case tyConFamInst_maybe tc of
-        Just (ptc, tys) -> (ppr ptc, hsep (map ppr (tys ++ drop (length tys) tc_args)))
-        _               -> (ppr tc, hsep (map ppr (tyConTyVars tc)))
+    (user_tc, tc_name, tc_tys) = case tyConFamInst_maybe tc of
+        Just (ptc, tys) -> (ptc, ppr ptc, hsep (map ppr (filter_kinds $ tys ++ drop (length tys) tc_args)))
+        _               -> (tc, ppr tc, hsep (map ppr (filter_kinds $ mkTyVarTys $ tyConTyVars tc)))
+
+    filter_kinds | gopt Opt_PrintExplicitKinds dflags
+                 = id
+                 | otherwise
+                 = filterOutInvisibleTypes user_tc
 
         -- Check (d) from Note [Requirements for deriving Generic and Rep].
         --
@@ -228,9 +239,9 @@ explicitly, even though foldDataConArgs is also doing this internally.
 -- are taken care of by the call to canDoGenerics.
 --
 -- It returns Nothing if deriving is possible. It returns (Just reason) if not.
-canDoGenerics1 :: TyCon -> [Type] -> Validity
-canDoGenerics1 rep_tc tc_args =
-  canDoGenerics rep_tc tc_args `andValid` additionalChecks
+canDoGenerics1 :: DynFlags -> TyCon -> [Type] -> Validity
+canDoGenerics1 dflags rep_tc tc_args =
+  canDoGenerics dflags rep_tc tc_args `andValid` additionalChecks
   where
     additionalChecks
         -- check (f) from Note [Requirements for deriving Generic and Rep]
diff --git a/testsuite/tests/deriving/should_compile/T11357.hs b/testsuite/tests/deriving/should_compile/T11357.hs
new file mode 100644
index 0000000..f3dc715
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T11357.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+module T11357 where
+
+import GHC.Generics (Generic1)
+
+data family   ProxyFam (a :: k)
+data instance ProxyFam (a :: k) = ProxyCon deriving Generic1
diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T
index ad235d6..e62c50c 100644
--- a/testsuite/tests/deriving/should_compile/all.T
+++ b/testsuite/tests/deriving/should_compile/all.T
@@ -64,3 +64,4 @@ test('T9968', normal, compile, [''])
 test('T11174', normal, compile, [''])
 test('T11416', normal, compile, [''])
 test('T11396', normal, compile, [''])
+test('T11357', normal, compile, [''])