Require DataKinds for promoted list/tuple syntax in types

Fixes Trac #7151

MERGED from commit 72e7f57c

compiler/rename/RnEnv.lhs

@@ -41,7 +41,7 @@ module RnEnv (
 	addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS,
 	warnUnusedMatches,
 	warnUnusedTopBinds, warnUnusedLocalBinds,
-	dataTcOccs, unknownNameErr, kindSigErr, dataKindsErr, perhapsForallMsg,
+        dataTcOccs, unknownNameErr, kindSigErr, perhapsForallMsg,
         HsDocContext(..), docOfHsDocContext
     ) where
 
@@ -1649,12 +1649,6 @@ kindSigErr thing
   = hang (ptext (sLit "Illegal kind signature for") <+> quotes (ppr thing))
        2 (ptext (sLit "Perhaps you intended to use -XKindSignatures"))
 
-dataKindsErr :: Outputable a => a -> SDoc
-dataKindsErr thing
-  = hang (ptext (sLit "Illegal kind:") <+> quotes (ppr thing))
-       2 (ptext (sLit "Perhaps you intended to use -XDataKinds"))
-
-
 badQualBndrErr :: RdrName -> SDoc
 badQualBndrErr rdr_name
   = ptext (sLit "Qualified name in binding position:") <+> ppr rdr_name

compiler/rename/RnTypes.lhs

@@ -207,7 +207,7 @@ rnHsTyKi isType doc (HsFunTy ty1 ty2)
 
 rnHsTyKi isType doc listTy@(HsListTy ty)
   = do { data_kinds <- xoptM Opt_DataKinds
-       ; unless (data_kinds || isType) (addErr (dataKindsErr listTy))
+       ; unless (data_kinds || isType) (addErr (dataKindsErr isType listTy))
        ; (ty', fvs) <- rnLHsTyKi isType doc ty
        ; return (HsListTy ty', fvs) }
 
@@ -228,7 +228,7 @@ rnHsTyKi isType doc (HsPArrTy ty)
 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
 rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys)
   = do { data_kinds <- xoptM Opt_DataKinds
-       ; unless (data_kinds || isType) (addErr (dataKindsErr tupleTy))
+       ; unless (data_kinds || isType) (addErr (dataKindsErr isType tupleTy))
        ; (tys', fvs) <- mapFvRn (rnLHsTyKi isType doc) tys
        ; return (HsTupleTy tup_con tys', fvs) }
 
@@ -236,7 +236,7 @@ rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys)
 -- 2. Check that the integer is positive?
 rnHsTyKi isType _ tyLit@(HsTyLit t)
   = do { data_kinds <- xoptM Opt_DataKinds
-       ; unless (data_kinds || isType) (addErr (dataKindsErr tyLit))
+       ; unless (data_kinds || isType) (addErr (dataKindsErr isType tyLit))
        ; return (HsTyLit t, emptyFVs) }
 
 rnHsTyKi isType doc (HsAppTy ty1 ty2)
@@ -284,14 +284,18 @@ rnHsTyKi isType _ (HsCoreTy ty)
 rnHsTyKi _ _ (HsWrapTy {}) 
   = panic "rnHsTyKi"
 
-rnHsTyKi isType doc (HsExplicitListTy k tys)
+rnHsTyKi isType doc ty@(HsExplicitListTy k tys)
   = ASSERT( isType )
-    do { (tys', fvs) <- rnLHsTypes doc tys
+    do { data_kinds <- xoptM Opt_DataKinds
+       ; unless data_kinds (addErr (dataKindsErr isType ty))
+       ; (tys', fvs) <- rnLHsTypes doc tys
        ; return (HsExplicitListTy k tys', fvs) }
 
-rnHsTyKi isType doc (HsExplicitTupleTy kis tys) 
+rnHsTyKi isType doc ty@(HsExplicitTupleTy kis tys) 
   = ASSERT( isType )
-    do { (tys', fvs) <- rnLHsTypes doc tys
+    do { data_kinds <- xoptM Opt_DataKinds
+       ; unless data_kinds (addErr (dataKindsErr isType ty))
+       ; (tys', fvs) <- rnLHsTypes doc tys
        ; return (HsExplicitTupleTy kis tys', fvs) }
 
 --------------
@@ -443,6 +447,14 @@ badSigErr is_type doc (L loc ty)
          | otherwise = ptext (sLit "kind")
     flag | is_type   = ptext (sLit "-XScopedTypeVariables")
          | otherwise = ptext (sLit "-XKindSignatures")
+
+dataKindsErr :: Bool -> HsType RdrName -> SDoc
+dataKindsErr is_type thing
+  = hang (ptext (sLit "Illegal") <+> what <> colon <+> quotes (ppr thing))
+       2 (ptext (sLit "Perhaps you intended to use -XDataKinds"))
+  where
+    what | is_type   = ptext (sLit "type")
+         | otherwise = ptext (sLit "kind")
 \end{code}
 
 Note [Renaming associated types] 

compiler/typecheck/TcHsType.lhs

@@ -48,7 +48,6 @@ import {-# SOURCE #-}	TcSplice( tcSpliceType )
 import HsSyn
 import TcHsSyn ( zonkTcTypeToType, emptyZonkEnv )
 import TcRnMonad
-import RnEnv   ( dataKindsErr )
 import TcEvidence( HsWrapper )
 import TcEnv
 import TcMType
@@ -1437,6 +1436,11 @@ tc_kind_var_app name arg_kis
    tycon_err tc msg = failWithTc (quotes (ppr tc) <+> ptext (sLit "of kind")
                                   <+> quotes (ppr (tyConKind tc)) <+> ptext (sLit msg))
 
+dataKindsErr :: Name -> SDoc
+dataKindsErr name
+  = hang (ptext (sLit "Illegal kind:") <+> quotes (ppr name))
+       2 (ptext (sLit "Perhaps you intended to use -XDataKinds"))
+
 promotionErr :: Name -> PromotionErr -> TcM a
 promotionErr name err
   = failWithTc (hang (pprPECategory err <+> quotes (ppr name) <+> ptext (sLit "cannot be used here"))