From b5c5024145668f76ca10610cba7901ed08eb0905 Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Mon, 19 Mar 2018 12:06:41 -0400
Subject: [PATCH] Don't permit data types with return kind Constraint
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Previously, GHC allowed all of the following:
```lang=haskell
data Foo1 :: Constraint
data family Foo2 :: Constraint
data family Foo3 :: k
data instance Foo3 :: Constraint
```
Yikes! This is because GHC was confusing `Type` with `Constraint`
due to careless use of the `isLiftedTypeKind` function. To respect
this distinction, I swapped `isLiftedTypeKind` out for
`tcIsStarKind`—which does respect this distinction—in the right
places.
Test Plan: make test TEST="T14048a T14048b T14048c"
Reviewers: bgamari
Reviewed By: bgamari
Subscribers: goldfire, rwbarton, thomie, carter
GHC Trac Issues: #14048
Differential Revision: https://phabricator.haskell.org/D4479
(cherry picked from commit f748c52997f61a9f58eccbf4b8df0a0c8c6887e5)
---
compiler/typecheck/TcInstDcls.hs | 5 +++--
compiler/typecheck/TcTyClsDecls.hs | 4 ++--
testsuite/tests/typecheck/should_fail/T14048a.hs | 6 ++++++
testsuite/tests/typecheck/should_fail/T14048a.stderr | 5 +++++
testsuite/tests/typecheck/should_fail/T14048b.hs | 7 +++++++
testsuite/tests/typecheck/should_fail/T14048b.stderr | 6 ++++++
testsuite/tests/typecheck/should_fail/T14048c.hs | 9 +++++++++
testsuite/tests/typecheck/should_fail/T14048c.stderr | 5 +++++
testsuite/tests/typecheck/should_fail/all.T | 3 +++
9 files changed, 46 insertions(+), 4 deletions(-)
create mode 100644 testsuite/tests/typecheck/should_fail/T14048a.hs
create mode 100644 testsuite/tests/typecheck/should_fail/T14048a.stderr
create mode 100644 testsuite/tests/typecheck/should_fail/T14048b.hs
create mode 100644 testsuite/tests/typecheck/should_fail/T14048b.stderr
create mode 100644 testsuite/tests/typecheck/should_fail/T14048c.hs
create mode 100644 testsuite/tests/typecheck/should_fail/T14048c.stderr
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index 99a6ff364c..7e9f93dcef 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -41,6 +41,7 @@ import TcUnify
import CoreSyn ( Expr(..), mkApps, mkVarApps, mkLams )
import MkCore ( nO_METHOD_BINDING_ERROR_ID )
import CoreUnfold ( mkInlineUnfoldingWithArity, mkDFunUnfolding )
+import Kind
import Type
import TcEvidence
import TyCon
@@ -680,7 +681,7 @@ tcDataFamInstDecl mb_clsinfo
-- Deal with any kind signature.
-- See also Note [Arity of data families] in FamInstEnv
; (extra_tcbs, final_res_kind) <- tcDataKindSig full_tcbs res_kind'
- ; checkTc (isLiftedTypeKind final_res_kind) (badKindSig True res_kind')
+ ; checkTc (tcIsStarKind final_res_kind) (badKindSig True res_kind')
; let extra_pats = map (mkTyVarTy . binderVar) extra_tcbs
all_pats = pats' `chkAppend` extra_pats
@@ -722,7 +723,7 @@ tcDataFamInstDecl mb_clsinfo
; checkValidFamPats mb_clsinfo fam_tc tvs' [] pats' extra_pats pp_hs_pats
-- Result kind must be '*' (otherwise, we have too few patterns)
- ; checkTc (isLiftedTypeKind final_res_kind) $
+ ; checkTc (tcIsStarKind final_res_kind) $
tooFewParmsErr (tyConArity fam_tc)
; checkValidTyCon rep_tc
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 9261905585..89ec2950a4 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -882,7 +882,7 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_na
-- Data families might have a variable return kind.
-- See See Note [Arity of data families] in FamInstEnv.
; (extra_binders, final_res_kind) <- tcDataKindSig binders res_kind
- ; checkTc (isLiftedTypeKind final_res_kind
+ ; checkTc (tcIsStarKind final_res_kind
|| isJust (tcGetCastedTyVar_maybe final_res_kind))
(badKindSig False res_kind)
@@ -1034,7 +1034,7 @@ tcDataDefn roles_info
; let hsc_src = tcg_src tcg_env
; (extra_bndrs, final_res_kind) <- tcDataKindSig tycon_binders res_kind
; unless (mk_permissive_kind hsc_src cons) $
- checkTc (isLiftedTypeKind final_res_kind) (badKindSig True res_kind)
+ checkTc (tcIsStarKind final_res_kind) (badKindSig True res_kind)
; let final_bndrs = tycon_binders `chkAppend` extra_bndrs
roles = roles_info tc_name
diff --git a/testsuite/tests/typecheck/should_fail/T14048a.hs b/testsuite/tests/typecheck/should_fail/T14048a.hs
new file mode 100644
index 0000000000..c717127df8
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T14048a.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE ConstraintKinds #-}
+module T14048a where
+
+import Data.Kind
+
+data Foo :: Constraint
diff --git a/testsuite/tests/typecheck/should_fail/T14048a.stderr b/testsuite/tests/typecheck/should_fail/T14048a.stderr
new file mode 100644
index 0000000000..48a91c7525
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T14048a.stderr
@@ -0,0 +1,5 @@
+
+T14048a.hs:6:1: error:
+ • Kind signature on data type declaration has non-* return kind
+ Constraint
+ • In the data declaration for ‘Foo’
diff --git a/testsuite/tests/typecheck/should_fail/T14048b.hs b/testsuite/tests/typecheck/should_fail/T14048b.hs
new file mode 100644
index 0000000000..d2f6f74583
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T14048b.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+module T14048b where
+
+import Data.Kind
+
+data family Foo :: Constraint
diff --git a/testsuite/tests/typecheck/should_fail/T14048b.stderr b/testsuite/tests/typecheck/should_fail/T14048b.stderr
new file mode 100644
index 0000000000..fe78d9f7f5
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T14048b.stderr
@@ -0,0 +1,6 @@
+
+T14048b.hs:7:1: error:
+ • Kind signature on data type declaration has non-*
+ and non-variable return kind
+ Constraint
+ • In the data family declaration for ‘Foo’
diff --git a/testsuite/tests/typecheck/should_fail/T14048c.hs b/testsuite/tests/typecheck/should_fail/T14048c.hs
new file mode 100644
index 0000000000..e81e454d31
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T14048c.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+module T14048c where
+
+import Data.Kind
+
+data family Foo :: k
+data instance Foo :: Constraint
diff --git a/testsuite/tests/typecheck/should_fail/T14048c.stderr b/testsuite/tests/typecheck/should_fail/T14048c.stderr
new file mode 100644
index 0000000000..7e83d1924c
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T14048c.stderr
@@ -0,0 +1,5 @@
+
+T14048c.hs:9:1: error:
+ • Kind signature on data type declaration has non-* return kind
+ Constraint
+ • In the data instance declaration for ‘Foo’
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index b1a0e757ae..734561f732 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -457,6 +457,9 @@ test('T14000', normal, compile_fail, [''])
test('T14055', normal, compile_fail, [''])
test('T13909', normal, compile_fail, [''])
test('T13929', normal, compile_fail, [''])
+test('T14048a', normal, compile_fail, [''])
+test('T14048b', normal, compile_fail, [''])
+test('T14048c', normal, compile_fail, [''])
test('T14232', normal, compile_fail, [''])
test('T14325', normal, compile_fail, [''])
test('T14350', normal, compile_fail, [''])
--
GitLab