[commit: ghc] ghc-8.4: Don't permit data types with return kind Constraint (b5c5024)

git at git.haskell.org git at git.haskell.org
Thu Mar 29 16:30:17 UTC 2018


Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-8.4
Link       : http://ghc.haskell.org/trac/ghc/changeset/b5c5024145668f76ca10610cba7901ed08eb0905/ghc

>---------------------------------------------------------------

commit b5c5024145668f76ca10610cba7901ed08eb0905
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Mon Mar 19 12:06:41 2018 -0400

    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 f748c52997f61a9f58eccbf4b8df0a0c8c6887e5)


>---------------------------------------------------------------

b5c5024145668f76ca10610cba7901ed08eb0905
 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(-)

diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index 99a6ff3..7e9f93d 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 9261905..89ec295 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 0000000..c717127
--- /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 0000000..48a91c7
--- /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 0000000..d2f6f74
--- /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 0000000..fe78d9f
--- /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 0000000..e81e454
--- /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 0000000..7e83d19
--- /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 b1a0e75..734561f 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, [''])



More information about the ghc-commits mailing list