Do not quantify over deriving clauses
authorSimon Peyton Jones <simonpj@microsoft.com>
Thu, 12 Oct 2017 08:25:25 +0000 (09:25 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Thu, 12 Oct 2017 08:25:25 +0000 (09:25 +0100)
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.

compiler/rename/RnTypes.hs
testsuite/tests/deriving/should_compile/T14331.hs [new file with mode: 0644]
testsuite/tests/deriving/should_compile/all.T

index dc519b5..dd66cd3 100644 (file)
@@ -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 (file)
index 0000000..4fe40fa
--- /dev/null
@@ -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))
index 82cee03..431129f 100644 (file)
@@ -97,3 +97,4 @@ test('T13998', normal, compile, [''])
 test('T14045b', normal, compile, [''])
 test('T14094', normal, compile, [''])
 test('T14339', normal, compile, [''])
+test('T14331', normal, compile, [''])