From 349c8c53ef9e99425d9ca299cbad388a21b63a54 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Wed, 15 Aug 2012 16:01:19 +0100
Subject: [PATCH] Require DataKinds for promoted list/tuple syntax in types
Fixes Trac #7151
MERGED from commit 72e7f57cb4326c797f63d0c0c976241c02328209
---
compiler/rename/RnEnv.lhs | 8 +-------
compiler/rename/RnTypes.lhs | 26 +++++++++++++++++++-------
compiler/typecheck/TcHsType.lhs | 6 +++++-
3 files changed, 25 insertions(+), 15 deletions(-)
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 6b01da47223a..61b56359fc91 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/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
diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index ed2144084ab5..d9809239e2e3 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/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]
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 8b4004490b79..77c4a8bbdd93 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/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"))
--
GitLab