Fix `:k` command: add validity checking

Summary:
This patch fixes #15806, where we found that the `:k` command in GHCi
misses a validity checking for the type.

Missing validity checking causes `:k` to accept types that are not validated.
For example, `:k (Maybe (forall a. a -> a))` (incorrectly) returns `*`, while
impredictivity of type instantiation shouldn't be allowed.

Test Plan: ./validate

Reviewers: simonpj, goldfire, bgamari

Reviewed By: bgamari

Subscribers: rwbarton, carter

GHC Trac Issues: #15806

Differential Revision: https://phabricator.haskell.org/D5265

6 files changed, 13 insertions, 1 deletions

diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index 24299dd84b..2194fa08fa 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -174,7 +174,7 @@ pprSigCtxt ctxt hs_ty
 
 tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type
 -- This one is used when we have a LHsSigWcType, but in
--- a place where wildards aren't allowed. The renamer has
+-- a place where wildcards aren't allowed. The renamer has
 -- already checked this, so we can simply ignore it.
 tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty)
 
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 814a580adc..1c04327bae 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -51,6 +51,7 @@ import {-# SOURCE #-} TcSplice ( finishTH, runRemoteModFinalizers )
 import RnSplice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )
 import IfaceEnv( externaliseName )
 import TcHsType
+import TcValidity( checkValidType )
 import TcMatches
 import Inst( deeplyInstantiate )
 import TcUnify( checkConstraints )
@@ -2397,6 +2398,9 @@ tcRnType hsc_env normalise rdr_type
        ; kvs <- kindGeneralize kind
        ; ty  <- zonkTcTypeToType ty
 
+       -- Do validity checking on type
+       ; checkValidType GhciCtxt ty
+
        ; ty' <- if normalise
                 then do { fam_envs <- tcGetFamInstEnvs
                         ; let (_, ty')
diff --git a/testsuite/tests/ghci/should_run/T15806.script b/testsuite/tests/ghci/should_run/T15806.script
new file mode 100644
index 0000000000..71f0dee143
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/T15806.script
@@ -0,0 +1,3 @@
+:set -XRankNTypes
+:k (Maybe Int)
+:k (Maybe (forall a. a -> a))
\ No newline at end of file
diff --git a/testsuite/tests/ghci/should_run/T15806.stderr b/testsuite/tests/ghci/should_run/T15806.stderr
new file mode 100644
index 0000000000..b7e0b4be56
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/T15806.stderr
@@ -0,0 +1,3 @@
+<interactive>:1:1: error:
+    Illegal polymorphic type: forall a. a -> a
+    GHC doesn't yet support impredicative polymorphism
\ No newline at end of file
diff --git a/testsuite/tests/ghci/should_run/T15806.stdout b/testsuite/tests/ghci/should_run/T15806.stdout
new file mode 100644
index 0000000000..f4e9f230dc
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/T15806.stdout
@@ -0,0 +1 @@
+(Maybe Int) :: *
\ No newline at end of file
diff --git a/testsuite/tests/ghci/should_run/all.T b/testsuite/tests/ghci/should_run/all.T
index 70e200c0d1..855b603656 100644
--- a/testsuite/tests/ghci/should_run/all.T
+++ b/testsuite/tests/ghci/should_run/all.T
@@ -35,3 +35,4 @@ test('T14963a', just_ghci, ghci_script, ['T14963a.script'])
 test('T14963b', just_ghci, ghci_script, ['T14963b.script'])
 test('T14963c', [extra_hc_opts("-fdefer-type-errors")], ghci_script, ['T14963c.script'])
 test('T15007', just_ghci, ghci_script, ['T15007.script'])
+test('T15806',     just_ghci, ghci_script, ['T15806.script'])