[commit: ghc] wip/rae: Fix #11355. (39532be)

[git at git.haskell.org]

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

On branch  : wip/rae
Link       : http://ghc.haskell.org/trac/ghc/changeset/39532bed3c8c81406cf00e544ac1db33ce94a3f3/ghc

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

commit 39532bed3c8c81406cf00e544ac1db33ce94a3f3
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Sat Jan 9 11:18:53 2016 -0500

    Fix #11355.
    
    Previously, the check for impredicative type applications was
    in the wrong spot.
    
    Test case: typecheck/should_fail/T11355


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

39532bed3c8c81406cf00e544ac1db33ce94a3f3
 compiler/typecheck/TcValidity.hs                    | 8 +++++++-
 testsuite/tests/typecheck/should_fail/T11355.hs     | 5 +++++
 testsuite/tests/typecheck/should_fail/T11355.stderr | 9 +++++++++
 testsuite/tests/typecheck/should_fail/all.T         | 1 +
 4 files changed, 22 insertions(+), 1 deletion(-)

diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs
index 79d3702..63118d0 100644
--- a/compiler/typecheck/TcValidity.hs
+++ b/compiler/typecheck/TcValidity.hs
@@ -291,6 +291,7 @@ checkValidType :: UserTypeCtxt -> Type -> TcM ()
 checkValidType ctxt ty
   = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (typeKind ty))
        ; rankn_flag  <- xoptM LangExt.RankNTypes
+       ; impred_flag <- xoptM LangExt.ImpredicativeTypes
        ; let gen_rank :: Rank -> Rank
              gen_rank r | rankn_flag = ArbitraryRank
                         | otherwise  = r
@@ -310,7 +311,12 @@ checkValidType ctxt ty
                  TySynCtxt _    -> rank0
 
                  ExprSigCtxt    -> rank1
-                 TypeAppCtxt    -> rank0
+                 TypeAppCtxt | impred_flag -> ArbitraryRank
+                             | otherwise   -> tyConArgMonoType
+                    -- Normally, ImpredicativeTypes is handled in check_arg_type,
+                    -- but visible type applications don't go through there.
+                    -- So we do this check here.
+
                  FunSigCtxt {}  -> rank1
                  InfSigCtxt _   -> ArbitraryRank        -- Inferred type
                  ConArgCtxt _   -> rank1 -- We are given the type of the entire
diff --git a/testsuite/tests/typecheck/should_fail/T11355.hs b/testsuite/tests/typecheck/should_fail/T11355.hs
new file mode 100644
index 0000000..4ec11d0
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T11355.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE TypeApplications, RankNTypes #-}
+
+module T11355 where
+
+foo = const @_ @((forall a. a) -> forall a. a) () (id @(forall a. a))
diff --git a/testsuite/tests/typecheck/should_fail/T11355.stderr b/testsuite/tests/typecheck/should_fail/T11355.stderr
new file mode 100644
index 0000000..cd3cc73
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T11355.stderr
@@ -0,0 +1,9 @@
+
+T11355.hs:5:7: error:
+    • Illegal polymorphic or qualified type: forall (a1 :: TYPE t0). a1
+      GHC doesn't yet support impredicative polymorphism
+    • In the expression:
+        const @_ @((forall a. a) -> forall a. a) () (id @(forall a. a))
+      In an equation for ‘foo’:
+          foo
+            = const @_ @((forall a. a) -> forall a. a) () (id @(forall a. a))
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index 753708d..9e37227 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -400,3 +400,4 @@ test('T11274', normal, compile_fail, [''])
 test('T10619', normal, compile_fail, [''])
 test('T11347', normal, compile_fail, [''])
 test('T11356', normal, compile_fail, [''])
+test('T11355', normal, compile_fail, [''])