[commit: ghc] wip/no-telescope-tvs: Fix #11821 by bringing only unzonked vars into scope. (93b9a7d)

[git at git.haskell.org]

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

On branch  : wip/no-telescope-tvs
Link       : http://ghc.haskell.org/trac/ghc/changeset/93b9a7ddd4156168b46f4b83d3d6469c5d246da5/ghc

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

commit 93b9a7ddd4156168b46f4b83d3d6469c5d246da5
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Tue Apr 26 12:05:13 2016 -0400

    Fix #11821 by bringing only unzonked vars into scope.


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

93b9a7ddd4156168b46f4b83d3d6469c5d246da5
 compiler/typecheck/TcHsType.hs      | 13 ++++++++-----
 compiler/typecheck/TcTyClsDecls.hs  |  3 ++-
 testsuite/tests/polykinds/T11821.hs | 31 +++++++++++++++++++++++++++++++
 testsuite/tests/polykinds/all.T     |  1 +
 4 files changed, 42 insertions(+), 6 deletions(-)

diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index e27872f..a9d6efe 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -1572,15 +1572,18 @@ tcTyClTyVars tycon_name thing_inside
   = do { tycon <- kcLookupTcTyCon tycon_name
 
           -- See Note [Free-floating kind vars]
-       ; all_scoped_tvs <- mapM zonkTcTyVarToTyVar $
-                           tcTyConScopedTyVars tycon
-       ; let (still_sig_tvs, good_tvs) = partition isSigTyVar all_scoped_tvs
-       ; checkNoErrs $ mapM_ (report_floating_kv all_scoped_tvs) still_sig_tvs
+       ; let scoped_tvs = tcTyConScopedTyVars tycon
+       ; zonked_scoped_tvs <- mapM zonkTcTyVarToTyVar scoped_tvs
+       ; let still_sig_tvs = filter isSigTyVar zonked_scoped_tvs
+       ; checkNoErrs $ mapM_ (report_floating_kv scoped_tvs) still_sig_tvs
 
        ; let tkvs     = tyConTyVars tycon
              binders  = tyConBinders tycon
              res_kind = tyConResKind tycon
-       ; tcExtendTyVarEnv good_tvs $
+
+          -- Add the *unzonked* tyvars to the env't, because those
+          -- are the ones mentioned in the source.
+       ; tcExtendTyVarEnv scoped_tvs $
          thing_inside tkvs binders res_kind }
   where
     report_floating_kv all_tvs kv
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 1ea8d41..c7b26f4 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -357,7 +357,8 @@ kcTyClGroup decls
                       -- Make sure kc_kind' has the final, zonked kind variables
            ; traceTc "Generalise kind" $
              vcat [ ppr name, ppr kc_binders, ppr kc_res_kind
-                  , ppr kvs, ppr kc_binders', ppr kc_res_kind' ]
+                  , ppr kvs, ppr kc_binders', ppr kc_res_kind'
+                  , ppr (tcTyConScopedTyVars tc)]
 
            ; return (mkTcTyCon name (kvs ++ kc_tyvars)
                                (mkNamedBinders Invisible kvs ++ kc_binders')
diff --git a/testsuite/tests/polykinds/T11821.hs b/testsuite/tests/polykinds/T11821.hs
new file mode 100644
index 0000000..82efeb5
--- /dev/null
+++ b/testsuite/tests/polykinds/T11821.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE RankNTypes, DataKinds, PolyKinds, GADTs, TypeFamilies, UndecidableInstances #-}
+module NotInScope where
+
+import Data.Proxy
+
+type KindOf (a :: k) = ('KProxy :: KProxy k)
+data TyFun :: * -> * -> *
+type family Apply (f :: TyFun k1 k2 -> *) (x :: k1) :: k2
+
+data Lgo2 l1
+          l2
+          l3
+          (l4 :: b)
+          (l5 :: TyFun [a] b)
+  = forall (arg :: [a]) . KindOf (Apply (Lgo2 l1 l2 l3 l4) arg) ~ KindOf (Lgo l1 l2 l3 l4 arg) =>
+    Lgo2KindInference
+
+data Lgo1 l1
+          l2
+          l3
+          (l4 :: TyFun b (TyFun [a] b -> *))
+  = forall (arg :: b) . KindOf (Apply (Lgo1 l1 l2 l3) arg) ~ KindOf (Lgo2 l1 l2 l3 arg) =>
+    Lgo1KindInference
+
+type family Lgo f
+                z0
+                xs0
+                (a1 :: b)
+                (a2 :: [a]) :: b where
+  Lgo f z0 xs0 z '[]         = z
+  Lgo f z0 xs0 z ('(:) x xs) = Apply (Apply (Lgo1 f z0 xs0) (Apply (Apply f z) x)) xs
diff --git a/testsuite/tests/polykinds/all.T b/testsuite/tests/polykinds/all.T
index 17d0211..f2e274b 100644
--- a/testsuite/tests/polykinds/all.T
+++ b/testsuite/tests/polykinds/all.T
@@ -146,3 +146,4 @@ test('T11611', normal, compile_fail, [''])
 test('T11648', normal, compile, [''])
 test('T11648b', normal, compile_fail, [''])
 test('KindVType', normal, compile_fail, [''])
+test('T11821', normal, compile, [''])