[commit: ghc] master: Check that type variable does not reference itself in its kind signature (8a76d32)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/8a76d32e4fbdafe787a0f5b2a492c0d0ea1ed980/ghc

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

commit 8a76d32e4fbdafe787a0f5b2a492c0d0ea1ed980
Author: John Leo <leo at halfaya.org>
Date:   Tue Jan 10 13:36:17 2017 -0500

    Check that type variable does not reference itself in its kind signature
    
    This fixes #11592.
    
    Test Plan: validate
    
    Reviewers: simonpj, austin, bgamari, goldfire
    
    Reviewed By: goldfire
    
    Subscribers: thomie
    
    Differential Revision: https://phabricator.haskell.org/D2914
    
    GHC Trac Issues: #11592


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

8a76d32e4fbdafe787a0f5b2a492c0d0ea1ed980
 compiler/rename/RnTypes.hs                       | 22 ++++++++++++++++------
 testsuite/tests/rename/should_fail/T11592.hs     | 10 ++++++++++
 testsuite/tests/rename/should_fail/T11592.stderr | 19 +++++++++++++++++++
 testsuite/tests/rename/should_fail/all.T         |  1 +
 4 files changed, 46 insertions(+), 6 deletions(-)

diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index f3fcf88..ec00511 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -918,19 +918,19 @@ bindLHsTyVarBndr :: HsDocContext
 bindLHsTyVarBndr doc mb_assoc kv_names tv_names hs_tv_bndr thing_inside
   = case hs_tv_bndr of
       L loc (UserTyVar lrdr@(L lv rdr)) ->
-        do { check_dup loc rdr
+        do { check_dup loc rdr []
            ; nm <- newTyVarNameRn mb_assoc lrdr
            ; bindLocalNamesFV [nm] $
              thing_inside [] emptyNameSet (L loc (UserTyVar (L lv nm))) }
       L loc (KindedTyVar lrdr@(L lv rdr) kind) ->
-        do { check_dup lv rdr
+        do { free_kvs <- freeKiTyVarsAllVars <$> extractHsTyRdrTyVars kind
+           ; check_dup lv rdr (map unLoc free_kvs)
 
              -- check for -XKindSignatures
            ; sig_ok <- xoptM LangExt.KindSignatures
            ; unless sig_ok (badKindSigErr doc kind)
 
              -- deal with kind vars in the user-written kind
-           ; free_kvs <- freeKiTyVarsAllVars <$> extractHsTyRdrTyVars kind
            ; bindImplicitKvs doc mb_assoc free_kvs tv_names $
              \ new_kv_nms other_kv_nms ->
              do { (kind', fvs1) <- rnLHsKind doc kind
@@ -943,9 +943,15 @@ bindLHsTyVarBndr doc mb_assoc kv_names tv_names hs_tv_bndr thing_inside
       -- make sure that the RdrName isn't in the sets of
       -- names. We can't just check that it's not in scope at all
       -- because we might be inside an associated class.
-    check_dup :: SrcSpan -> RdrName -> RnM ()
-    check_dup loc rdr
-      = do { m_name <- lookupLocalOccRn_maybe rdr
+    check_dup :: SrcSpan -> RdrName -> [RdrName] -> RnM ()
+    check_dup loc rdr kindFreeVars
+      = do { -- Disallow use of a type variable name in its
+             -- kind signature (#11592).
+             when (rdr `elem` kindFreeVars) $
+             addErrAt loc (vcat [ ki_ty_self_err rdr
+                                , pprHsDocContext doc ])
+
+           ; m_name <- lookupLocalOccRn_maybe rdr
            ; whenIsJust m_name $ \name ->
         do { when (name `elemNameSet` kv_names) $
              addErrAt loc (vcat [ ki_ty_err_msg name
@@ -957,6 +963,10 @@ bindLHsTyVarBndr doc mb_assoc kv_names tv_names hs_tv_bndr thing_inside
                       text "used as a kind variable before being bound" $$
                       text "as a type variable. Perhaps reorder your variables?"
 
+    ki_ty_self_err n = text "Variable" <+> quotes (ppr n) <+>
+                       text "is used in the kind signature of its" $$
+                       text "declaration as a type variable."
+
 
 bindImplicitKvs :: HsDocContext
                 -> Maybe a
diff --git a/testsuite/tests/rename/should_fail/T11592.hs b/testsuite/tests/rename/should_fail/T11592.hs
new file mode 100644
index 0000000..b963cdf
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T11592.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE TypeInType #-}
+
+module Bug11592 where
+
+data A (a :: a) = MkA String
+
+data B b (a :: a b) = MkB String
+data C b (a :: b a) = MkC String
+
+data D b c (a :: c a b) = MkD String
diff --git a/testsuite/tests/rename/should_fail/T11592.stderr b/testsuite/tests/rename/should_fail/T11592.stderr
new file mode 100644
index 0000000..bffea1c
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T11592.stderr
@@ -0,0 +1,19 @@
+T11592.hs:5:9:
+    Variable ‘a’ is used in the kind signature of its
+    declaration as a type variable.
+    the data type declaration for ‘A’
+
+T11592.hs:7:11:
+    Variable ‘a’ is used in the kind signature of its
+    declaration as a type variable.
+    the data type declaration for ‘B’
+
+T11592.hs:8:11:
+    Variable ‘a’ is used in the kind signature of its
+    declaration as a type variable.
+    the data type declaration for ‘C’
+
+T11592.hs:10:13:
+    Variable ‘a’ is used in the kind signature of its
+    declaration as a type variable.
+    the data type declaration for ‘D’
diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T
index d42ca56..05fc5e4 100644
--- a/testsuite/tests/rename/should_fail/all.T
+++ b/testsuite/tests/rename/should_fail/all.T
@@ -142,4 +142,5 @@ test('T11663', normal, compile_fail, [''])
 test('T12229', normal, compile, [''])
 test('T12681', normal, multimod_compile_fail, ['T12681','-v0'])
 test('T12686', normal, compile_fail, [''])
+test('T11592', normal, compile_fail, [''])
 test('T12879', normal, compile_fail, [''])