[commit: ghc] wip/rae: Fix #11241. (43468fe)

[git at git.haskell.org]

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

On branch  : wip/rae
Link       : http://ghc.haskell.org/trac/ghc/changeset/43468fe386571564a4bdfc35cbaeab4199259318/ghc

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

commit 43468fe386571564a4bdfc35cbaeab4199259318
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Wed Feb 10 08:35:22 2016 -0500

    Fix #11241.
    
    When renaming a type, now looks for wildcards in bound variables'
    kinds.
    
    testcase: dependent/should_compile/T11241


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

43468fe386571564a4bdfc35cbaeab4199259318
 compiler/rename/RnTypes.hs                             | 9 ++++++++-
 testsuite/tests/dependent/should_compile/T11241.hs     | 6 ++++++
 testsuite/tests/dependent/should_compile/T11241.stderr | 6 ++++++
 testsuite/tests/dependent/should_compile/all.T         | 2 +-
 4 files changed, 21 insertions(+), 2 deletions(-)

diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index 0d7f68c..118a32b 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -147,7 +147,9 @@ rnWcSigTy env (L loc hs_ty@(HsForAllTy { hst_bndrs = tvs, hst_body = hs_tau }))
                       Nothing [] tvs $ \ _ tvs' ->
     do { (hs_tau', fvs) <- rnWcSigTy env hs_tau
        ; let hs_ty' = HsForAllTy { hst_bndrs = tvs', hst_body = hswc_body hs_tau' }
-       ; return ( hs_tau' { hswc_body = L loc hs_ty' }, fvs) }
+             awcs_bndrs = collectAnonWildCardsBndrs tvs'
+       ; return ( hs_tau' { hswc_wcs = hswc_wcs hs_tau' ++ awcs_bndrs
+                          , hswc_body = L loc hs_ty' }, fvs) }
 
 rnWcSigTy env (L loc (HsQualTy { hst_ctxt = hs_ctxt, hst_body = tau }))
   = do { (hs_ctxt', fvs1) <- rnWcSigContext env hs_ctxt
@@ -1043,6 +1045,11 @@ collectAnonWildCards lty = go lty
     prefix_types_only (HsAppPrefix ty) = Just ty
     prefix_types_only (HsAppInfix _)   = Nothing
 
+collectAnonWildCardsBndrs :: [LHsTyVarBndr Name] -> [Name]
+collectAnonWildCardsBndrs ltvs = concatMap (go . unLoc) ltvs
+  where
+    go (UserTyVar _)      = []
+    go (KindedTyVar _ ki) = collectAnonWildCards ki
 
 {-
 *********************************************************
diff --git a/testsuite/tests/dependent/should_compile/T11241.hs b/testsuite/tests/dependent/should_compile/T11241.hs
new file mode 100644
index 0000000..47d20d6
--- /dev/null
+++ b/testsuite/tests/dependent/should_compile/T11241.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE ExplicitForAll, KindSignatures, PartialTypeSignatures #-}
+
+module T11241 where
+
+foo :: forall (a :: _) . a -> a
+foo = id
diff --git a/testsuite/tests/dependent/should_compile/T11241.stderr b/testsuite/tests/dependent/should_compile/T11241.stderr
new file mode 100644
index 0000000..49a39a9
--- /dev/null
+++ b/testsuite/tests/dependent/should_compile/T11241.stderr
@@ -0,0 +1,6 @@
+
+T11241.hs:5:21: warning:
+    • Found type wildcard ‘_’ standing for ‘*’
+    • In the type signature:
+        foo :: forall (a :: _). a -> a
+    • Relevant bindings include foo :: a -> a (bound at T11241.hs:6:1)
diff --git a/testsuite/tests/dependent/should_compile/all.T b/testsuite/tests/dependent/should_compile/all.T
index 571a9fb..783fa16 100644
--- a/testsuite/tests/dependent/should_compile/all.T
+++ b/testsuite/tests/dependent/should_compile/all.T
@@ -16,4 +16,4 @@ test('T9632', normal, compile, [''])
 test('dynamic-paper', expect_fail_for(['optasm', 'optllvm']), compile, [''])
 test('T11311', normal, compile, [''])
 test('T11405', normal, compile, [''])
-
+test('T11241', normal, compile, [''])