[commit: ghc] ghc-8.2: Do not quantify over deriving clauses (f0b46f3)

[git at git.haskell.org]

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

On branch  : ghc-8.2
Link       : http://ghc.haskell.org/trac/ghc/changeset/f0b46f3e6a42c29e6d802078e357daf33666ba99/ghc

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

commit f0b46f3e6a42c29e6d802078e357daf33666ba99
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.
    
    (cherry picked from commit 82b77ec375ab74678ac2afecf55dc574fa24490f)


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

f0b46f3e6a42c29e6d802078e357daf33666ba99
 compiler/rename/RnTypes.hs                        | 22 +++++++++++++---------
 testsuite/tests/deriving/should_compile/T14331.hs | 10 ++++++++++
 testsuite/tests/deriving/should_compile/all.T     |  4 ++++
 3 files changed, 27 insertions(+), 9 deletions(-)

diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index 589cc02..50e57e5 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -1598,14 +1598,23 @@ extractRdrKindSigVars (L _ resultSig)
 
 extractDataDefnKindVars :: HsDataDefn RdrName -> 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
@@ -1623,11 +1632,6 @@ extract_lctxt :: TypeOrKind
               -> LHsContext RdrName -> FreeKiTyVars -> RnM FreeKiTyVars
 extract_lctxt t_or_k ctxt = extract_ltys t_or_k (unLoc ctxt)
 
-extract_sig_tys :: [LHsSigType RdrName] -> 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 RdrName] -> 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 5c3f970..5f94f9d 100644
--- a/testsuite/tests/deriving/should_compile/all.T
+++ b/testsuite/tests/deriving/should_compile/all.T
@@ -1,3 +1,6 @@
+def just_the_deriving( msg ):
+  return msg[0:msg.find('Filling in method body')]
+
 test('drv001', normal, compile, [''])
 test('drv002', normal, compile, [''])
 test('drv003', normal, compile, [''])
@@ -85,3 +88,4 @@ test('T12814', normal, compile, ['-Wredundant-constraints'])
 test('T13272', normal, compile, [''])
 test('T13272a', normal, compile, [''])
 test('T13297', normal, compile, [''])
+test('T14331', normal, compile, [''])