Don't permit data types with return kind Constraint
authorRyan Scott <ryan.gl.scott@gmail.com>
Mon, 19 Mar 2018 16:06:41 +0000 (12:06 -0400)
committerBen Gamari <ben@smart-cactus.org>
Mon, 19 Mar 2018 16:06:45 +0000 (12:06 -0400)
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

compiler/typecheck/TcInstDcls.hs
compiler/typecheck/TcTyClsDecls.hs
testsuite/tests/typecheck/should_fail/T14048a.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T14048a.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T14048b.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T14048b.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T14048c.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T14048c.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/all.T

index 9f623fc..7e44c4a 100644 (file)
@@ -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
index 7436b0d..39697d6 100644 (file)
@@ -886,7 +886,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)
 
@@ -1038,7 +1038,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 (file)
index 0000000..c717127
--- /dev/null
@@ -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 (file)
index 0000000..48a91c7
--- /dev/null
@@ -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 (file)
index 0000000..d2f6f74
--- /dev/null
@@ -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 (file)
index 0000000..fe78d9f
--- /dev/null
@@ -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 (file)
index 0000000..e81e454
--- /dev/null
@@ -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 (file)
index 0000000..7e83d19
--- /dev/null
@@ -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’
index 5377fef..f01cbe1 100644 (file)
@@ -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, [''])