[commit: ghc] master: Do not quantify over deriving clauses (82b77ec)

[git at git.haskell.org]

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

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

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

commit 82b77ec375ab74678ac2afecf55dc574fa24490f
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Thu Oct 12 09:25:25 2017 +0100

    Do not quantify over deriving clauses
    
    Trac #14331 showed that in a data type decl like
    
       data D = D deriving (C (a :: k))
    
    we were quantifying D over the 'k' in the deriving clause.  Yikes.
    
    Easily fixed, by deleting code in RnTypes.extractDataDefnKindVars
    
    See the discussion on the ticket, esp comment:8.


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

82b77ec375ab74678ac2afecf55dc574fa24490f
 compiler/rename/RnTypes.hs                        | 22 +++++++++++++---------
 testsuite/tests/deriving/should_compile/T14331.hs | 10 ++++++++++
 testsuite/tests/deriving/should_compile/all.T     |  1 +
 3 files changed, 24 insertions(+), 9 deletions(-)

diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index dc519b5..dd66cd3 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -1719,14 +1719,23 @@ extractRdrKindSigVars (L _ resultSig)
 
 extractDataDefnKindVars :: HsDataDefn GhcPs -> RnM [Located RdrName]
 -- Get the scoped kind variables mentioned free in the constructor decls
--- Eg    data T a = T1 (S (a :: k) | forall (b::k). T2 (S b)
--- Here k should scope over the whole definition
+-- Eg: data T a = T1 (S (a :: k) | forall (b::k). T2 (S b)
+--     Here k should scope over the whole definition
+--
+-- However, do NOT collect free kind vars from the deriving clauses:
+-- Eg: (Trac #14331)    class C p q
+--                      data D = D deriving ( C (a :: k) )
+--     Here k should /not/ scope over the whole definition.  We intend
+--     this to elaborate to:
+--         class C @k1 @k2 (p::k1) (q::k2)
+--         data D = D
+--         instance forall k (a::k). C @k @* a D where ...
+--
 extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig
-                                    , dd_cons = cons, dd_derivs = L _ derivs })
+                                    , dd_cons = cons })
   = (nubL . freeKiTyVarsKindVars) <$>
     (extract_lctxt TypeLevel ctxt =<<
      extract_mb extract_lkind ksig =<<
-     extract_sig_tys (concatMap (unLoc . deriv_clause_tys . unLoc) derivs) =<<
      foldrM (extract_con . unLoc) emptyFKTV cons)
   where
     extract_con (ConDeclGADT { }) acc = return acc
@@ -1744,11 +1753,6 @@ extract_lctxt :: TypeOrKind
               -> LHsContext GhcPs -> FreeKiTyVars -> RnM FreeKiTyVars
 extract_lctxt t_or_k ctxt = extract_ltys t_or_k (unLoc ctxt)
 
-extract_sig_tys :: [LHsSigType GhcPs] -> FreeKiTyVars -> RnM FreeKiTyVars
-extract_sig_tys sig_tys acc
-  = foldrM (\sig_ty acc -> extract_lty TypeLevel (hsSigType sig_ty) acc)
-           acc sig_tys
-
 extract_ltys :: TypeOrKind
              -> [LHsType GhcPs] -> FreeKiTyVars -> RnM FreeKiTyVars
 extract_ltys t_or_k tys acc = foldrM (extract_lty t_or_k) acc tys
diff --git a/testsuite/tests/deriving/should_compile/T14331.hs b/testsuite/tests/deriving/should_compile/T14331.hs
new file mode 100644
index 0000000..4fe40fa
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T14331.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeInType #-}
+module Bug where
+
+class C p q
+
+data D = D deriving (C (a :: k))
diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T
index 82cee03..431129f 100644
--- a/testsuite/tests/deriving/should_compile/all.T
+++ b/testsuite/tests/deriving/should_compile/all.T
@@ -97,3 +97,4 @@ test('T13998', normal, compile, [''])
 test('T14045b', normal, compile, [''])
 test('T14094', normal, compile, [''])
 test('T14339', normal, compile, [''])
+test('T14331', normal, compile, [''])