[commit: ghc] master: Fix Trac #7128, by zonking kind varaibles more assiduously when typechecking a class declaration (e949162)

[Simon Peyton Jones]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/e949162653b65d8e48573e84583c6509be2f24ed

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

commit e949162653b65d8e48573e84583c6509be2f24ed
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Aug 14 17:06:00 2012 +0100

    Fix Trac #7128, by zonking kind varaibles more assiduously when typechecking a class declaration

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

 compiler/typecheck/TcHsSyn.lhs      |    2 +-
 compiler/typecheck/TcTyClsDecls.lhs |   19 +++++++++++++++----
 2 files changed, 16 insertions(+), 5 deletions(-)

diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index d1a82b2..1ddcd31 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -29,7 +29,7 @@ module TcHsSyn (
 	zonkTopDecls, zonkTopExpr, zonkTopLExpr, 
 	zonkTopBndrs, zonkTyBndrsX,
         emptyZonkEnv, mkEmptyZonkEnv, mkTyVarZonkEnv, 
-        zonkTcTypeToType, zonkTcTypeToTypes
+        zonkTcTypeToType, zonkTcTypeToTypes, zonkTyVarOcc,
   ) where
 
 #include "HsVersions.h"
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 5784788..40210bc 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -568,12 +568,15 @@ tcTyClDecl1 _parent calc_isrec
 
           ; ctxt' <- tcHsContext ctxt
           ; ctxt' <- zonkTcTypeToTypes emptyZonkEnv ctxt'  
-                     -- Squeeze out any kind unification variables
-
+                  -- Squeeze out any kind unification variables
           ; fds'  <- mapM (addLocM tc_fundep) fundeps
           ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths
+          ; env <- getLclTypeEnv
+          ; traceTc "tcClassDecl" (ppr fundeps $$ ppr tvs' $$ ppr fds' $$  ppr env)
           ; return (tvs', ctxt', fds', sig_stuff, gen_dm_env) }
 
+
+
   ; clas <- fixM $ \ clas -> do
 	    { let 	-- This little knot is just so we can get
 			-- hold of the name of the class TyCon, which we
@@ -602,9 +605,17 @@ tcTyClDecl1 _parent calc_isrec
       --     tying the the type and class declaration type checking knot.
   }
   where
-    tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM tcLookupTyVar tvs1 ;
-				; tvs2' <- mapM tcLookupTyVar tvs2 ;
+    tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM tc_fd_tyvar tvs1 ;
+				; tvs2' <- mapM tc_fd_tyvar tvs2 ;
 				; return (tvs1', tvs2') }
+    tc_fd_tyvar name   -- Scoped kind variables are bound to unification variables
+                       -- which are now fixed, so we can zonk
+      = do { tv <- tcLookupTyVar name
+           ; ty <- zonkTyVarOcc emptyZonkEnv tv
+                  -- Squeeze out any kind unification variables
+           ; case getTyVar_maybe ty of
+               Just tv' -> return tv'
+               Nothing  -> pprPanic "tc_fd_tyvar" (ppr name $$ ppr tv $$ ppr ty) }
 
 tcTyClDecl1 _ _
   (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name})