[commit: ghc] ghc-kinds: kind generalize type synonyms (c8bebe1)

[Julien Cretin]

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

On branch  : ghc-kinds

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

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

commit c8bebe1cc95e950423b8ce245dc31d00078a8dbd
Author: Julien Cretin <ghc at ia0.eu>
Date:   Thu Sep 22 14:59:57 2011 +0200

    kind generalize type synonyms

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

 compiler/typecheck/TcMType.lhs      |    1 +
 compiler/typecheck/TcTyClsDecls.lhs |   10 +++++++---
 compiler/types/Type.lhs             |    2 +-
 compiler/types/Unify.lhs            |   13 ++++++++-----
 4 files changed, 17 insertions(+), 9 deletions(-)

diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 9b8843b..eace945 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -351,6 +351,7 @@ writeMetaTyVarRef tyvar ref ty
 -- Everything from here on only happens if DEBUG is on
   | not (isPredTy tv_kind)   -- Don't check kinds for updates to coercion variables
   , not (ty_kind `isSubKind` tv_kind)
+  -- IA0_TODO: the kind are not zonked sometimes
   = WARN( True, hang (text "Ill-kinded update to meta tyvar")
                    2 (ppr tyvar $$ ppr tv_kind $$ ppr ty $$ ppr ty_kind) )
     do { traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty)
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index d1b26fb..cf4a731 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -236,9 +236,13 @@ kcTyClGroup decls
 	     -- Kind checking done for this group
 	     -- See Note [Kind checking for type and class decls]
              -- Now we have to kind generalize the flexis
-        ; let alg_kinds = [ (name, kind) | (name, AThing kind) <- initial_kinds ]
-        ; generalized_kinds <- flip mapM alg_kinds $ \(name, kc_kind) -> do
-                    { (kvs, body) <- kindGeneralizeKind kc_kind
+        ; let all_names = map (unLoc . tcdLName . unLoc) (syn_decls ++ alg_at_decls)
+        ; generalized_kinds <- flip mapM all_names $ \name -> do
+                    { thing <- tcLookup name
+                    ; let kc_kind = case thing of
+                                      AThing k -> k
+                                      _ -> pprPanic "kcTyClGroup" (ppr thing)
+                    ; (kvs, body) <- kindGeneralizeKind kc_kind
                     ; return $ (name, mkForAllTys kvs body) }
         ; traceTc "tcTyAndCl generalized" (ppr generalized_kinds)
         ; tcExtendKindEnv generalized_kinds getLclEnv } } }
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 00209d1..71829a3 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -1431,7 +1431,7 @@ substTyVarBndr subst@(TvSubst in_scope tenv) old_var
 	-- Here we must simply zap the substitution for x
 
     new_var | no_kind_change = uniqAway in_scope old_var
-            | otherwise = uniqAway in_scope $ setTyVarKind old_var (substTy subst old_ki)
+            | otherwise = uniqAway in_scope $ updateTyVarKind (substTy subst) old_var
 	-- The uniqAway part makes sure the new variable is not already in scope
 
 cloneTyVarBndr :: TvSubst -> TyVar -> Unique -> (TvSubst, TyVar)
diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs
index 2756aa3..f9d0b53 100644
--- a/compiler/types/Unify.lhs
+++ b/compiler/types/Unify.lhs
@@ -179,7 +179,8 @@ match menv subst (TyVarTy tv1) ty2
     tv1' = rnOccL rn_env tv1
 
 match menv subst (ForAllTy tv1 ty1) (ForAllTy tv2 ty2) 
-  = match menv' subst ty1 ty2
+  = do { subst' <- match_kind menv subst (tyVarKind tv1) (tyVarKind tv2)
+       ; match menv' subst' ty1 ty2 }
   where		-- Use the magic of rnBndr2 to go under the binders
     menv' = menv { me_env = rnBndr2 (me_env menv) tv1 tv2 }
 
@@ -201,10 +202,12 @@ match _ _ _ _
 match_kind :: MatchEnv -> TvSubstEnv -> Kind -> Kind -> Maybe TvSubstEnv
 -- Match the kind of the template tyvar with the kind of Type
 -- Note [Matching kinds]
--- IA0_TODO: we may need to unify k1 and k2 and modify subst
-match_kind _ subst k1 k2
-  | k2 `isSubKind` k1 = return subst
-match_kind menv subst k1 k2 = match menv subst k1 k2
+match_kind menv subst k1 k2
+  | k2 `isSubKind` k1
+  = return subst
+
+  | otherwise
+  = match menv subst k1 k2
 
 -- Note [Matching kinds]
 -- ~~~~~~~~~~~~~~~~~~~~~