[commit: ghc] master: Use the right kinds on the LHS in 'deriving' clauses (6ce708c)

[git at git.haskell.org]

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

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

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

commit 6ce708c916e2f14a58a4ee2b865bc9026a68d611
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Thu Jul 24 12:49:04 2014 +0100

    Use the right kinds on the LHS in 'deriving' clauses
    
    This patch fixes Trac #9359


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

6ce708c916e2f14a58a4ee2b865bc9026a68d611
 compiler/typecheck/TcDeriv.lhs                   | 36 +++++++++++++++++-------
 testsuite/tests/deriving/should_compile/T9359.hs | 12 ++++++++
 testsuite/tests/deriving/should_compile/all.T    |  1 +
 3 files changed, 39 insertions(+), 10 deletions(-)

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index d18c21c..fa775df 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -20,7 +20,7 @@ import FamInst
 import TcErrors( reportAllUnsolved )
 import TcValidity( validDerivPred )
 import TcEnv
-import TcTyClsDecls( tcFamTyPats, famTyConShape, tcAddDataFamInstCtxt )
+import TcTyClsDecls( tcFamTyPats, famTyConShape, tcAddDataFamInstCtxt, kcDataDefn )
 import TcClassDcl( tcAddDeclCtxt )      -- Small helper
 import TcGenDeriv                       -- Deriv stuff
 import TcGenGenerics
@@ -598,22 +598,38 @@ deriveInstDecl (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam
 ------------------------------------------------------------------
 deriveFamInst :: DataFamInstDecl Name -> TcM [EarlyDerivSpec]
 deriveFamInst decl@(DataFamInstDecl { dfid_tycon = L _ tc_name, dfid_pats = pats
-                                    , dfid_defn = HsDataDefn { dd_derivs = Just preds } })
+                                    , dfid_defn = defn@(HsDataDefn { dd_derivs = Just preds }) })
   = tcAddDataFamInstCtxt decl $
     do { fam_tc <- tcLookupTyCon tc_name
-       ; tcFamTyPats (famTyConShape fam_tc) pats (\_ -> return ()) $
+       ; tcFamTyPats (famTyConShape fam_tc) pats (kcDataDefn defn) $
+             -- kcDataDefn defn: see Note [Finding the LHS patterns]
          \ tvs' pats' _ ->
            concatMapM (deriveTyData True tvs' fam_tc pats') preds }
-        -- Tiresomely we must figure out the "lhs", which is awkward for type families
-        -- E.g.   data T a b = .. deriving( Eq )
-        --          Here, the lhs is (T a b)
-        --        data instance TF Int b = ... deriving( Eq )
-        --          Here, the lhs is (TF Int b)
-        -- But if we just look up the tycon_name, we get is the *family*
-        -- tycon, but not pattern types -- they are in the *rep* tycon.
 
 deriveFamInst _ = return []
+\end{code}
+
+Note [Finding the LHS patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When kind polymorphism is in play, we need to be careful.  Here is
+Trac #9359:
+  data Cmp a where
+    Sup :: Cmp a
+    V   :: a -> Cmp a
+
+  data family   CmpInterval (a :: Cmp k) (b :: Cmp k) :: *
+  data instance CmpInterval (V c) Sup = Starting c deriving( Show )
+
+So CmpInterval is kind-polymorphic, but the data instance is not
+   CmpInterval :: forall k. Cmp k -> Cmp k -> *
+   data instance CmpInterval * (V (c::*)) Sup = Starting c deriving( Show )
 
+Hence, when deriving the type patterns in deriveFamInst, we must kind
+check the RHS (the data constructor 'Starting c') as well as the LHS,
+so that we correctly see the instantiation to *.
+
+
+\begin{code}
 ------------------------------------------------------------------
 deriveStandalone :: LDerivDecl Name -> TcM [EarlyDerivSpec]
 -- Standalone deriving declarations
diff --git a/testsuite/tests/deriving/should_compile/T9359.hs b/testsuite/tests/deriving/should_compile/T9359.hs
new file mode 100644
index 0000000..313d66e
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T9359.hs
@@ -0,0 +1,12 @@
+{-# Language GADTs, PolyKinds, TypeFamilies, DataKinds #-}
+module Fam where
+
+data Cmp a where
+ Sup ::      Cmp a
+ V   :: a -> Cmp a
+ deriving (Show, Eq)
+
+data family   CmpInterval (a :: Cmp k) (b :: Cmp k) :: *
+data instance CmpInterval (V c)         Sup          = Starting c
+  deriving( Show )
+
diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T
index f440e80..af05006 100644
--- a/testsuite/tests/deriving/should_compile/all.T
+++ b/testsuite/tests/deriving/should_compile/all.T
@@ -51,3 +51,4 @@ test('T8950', expect_broken(8950), compile, [''])
 test('T8963', normal, compile, [''])
 test('T7269', normal, compile, [''])
 test('T9069', normal, compile, [''])
+test('T9359', normal, compile, [''])