Commit b5c50241 authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

Don't permit data types with return kind Constraint

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 f748c529)
parent 02aa02f1
......@@ -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
......
......@@ -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
......
{-# LANGUAGE ConstraintKinds #-}
module T14048a where
import Data.Kind
data Foo :: Constraint
T14048a.hs:6:1: error:
• Kind signature on data type declaration has non-* return kind
Constraint
• In the data declaration for ‘Foo’
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
module T14048b where
import Data.Kind
data family Foo :: Constraint
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’
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
module T14048c where
import Data.Kind
data family Foo :: k
data instance Foo :: Constraint
T14048c.hs:9:1: error:
• Kind signature on data type declaration has non-* return kind
Constraint
• In the data instance declaration for ‘Foo’
......@@ -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, [''])
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment