[commit: ghc] ghc-kinds: unify kinds in the pure unifier (66d3aa0)

[Julien Cretin]

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

On branch  : ghc-kinds

http://hackage.haskell.org/trac/ghc/changeset/66d3aa0eb90df184c934ec10e65459eb48b9ff40

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

commit 66d3aa0eb90df184c934ec10e65459eb48b9ff40
Author: Julien Cretin <ghc at ia0.eu>
Date:   Thu Sep 22 19:48:43 2011 +0200

    unify kinds in the pure unifier

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

 compiler/basicTypes/Var.lhs       |    4 +-
 compiler/typecheck/TcRnDriver.lhs |    1 +
 compiler/types/Unify.lhs          |   41 +++++++++++++++++++-----------------
 3 files changed, 25 insertions(+), 21 deletions(-)

diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs
index a87b4b1..c8643fb 100644
--- a/compiler/basicTypes/Var.lhs
+++ b/compiler/basicTypes/Var.lhs
@@ -190,8 +190,8 @@ After CoreTidy, top-level LocalIds are turned into GlobalIds
 
 \begin{code}
 instance Outputable Var where
-  ppr var = ppr (varName var) <+> ifPprDebug (brackets (ppr_debug var))
-            <+> text ":: (" <+> ppr (tyVarKind var) <+> text ")"  -- IA0_DEBUG: remove this line
+  ppr var = ifPprDebug (text "(") <+> ppr (varName var) <+> ifPprDebug (brackets (ppr_debug var))
+            <+> ifPprDebug (text "::" <+> ppr (tyVarKind var) <+> text ")")
 
 ppr_debug :: Var -> SDoc
 ppr_debug (TyVar {})                           = ptext (sLit "tv")
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 41d4ccc..de31e29 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -951,6 +951,7 @@ tcTopSrcDecls boot_details
                                  , tcg_vects = tcg_vects tcg_env ++ vects
                                  , tcg_anns  = tcg_anns tcg_env ++ annotations
                                  , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
+
         return (tcg_env', tcl_env)
     }}}}}}
 \end{code}
diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs
index f9d0b53..52e03ef 100644
--- a/compiler/types/Unify.lhs
+++ b/compiler/types/Unify.lhs
@@ -508,26 +508,29 @@ uUnrefined subst tv1 ty2 (TyVarTy tv2)
   | Just ty' <- lookupVarEnv subst tv2
   = uUnrefined subst tv1 ty' ty'
 
+  | otherwise
   -- So both are unrefined; next, see if the kinds force the direction
-  -- IA0_TODO: we might need to call unify instead
-  | eqKind k1 k2	-- Can update either; so check the bind-flags
-  = do	{ b1 <- tvBindFlag tv1
-	; b2 <- tvBindFlag tv2
-	; case (b1,b2) of
-	    (BindMe, _) 	 -> bind tv1 ty2
-	    (Skolem, Skolem)	 -> failWith (misMatch ty1 ty2)
-	    (Skolem, _)		 -> bind tv2 ty1
-	}
-
-  | k1 `isSubKind` k2 = bindTv subst tv2 ty1  -- Must update tv2
-  | k2 `isSubKind` k1 = bindTv subst tv1 ty2  -- Must update tv1
-
-  | otherwise = failWith (kindMisMatch tv1 ty2)
-  where
-    ty1 = TyVarTy tv1
-    k1 = tyVarKind tv1
-    k2 = tyVarKind tv2
-    bind tv ty = return $ extendVarEnv subst tv ty
+  = case (k1_sub_k2, k2_sub_k1) of
+        (True,  True)  -> choose subst
+        (True,  False) -> bindTv subst tv2 ty1
+        (False, True)  -> bindTv subst tv1 ty2
+        (False, False) -> do
+            { subst' <- unify subst k1 k2
+            ; choose subst' }
+  where subst_kind = mkTvSubst (mkInScopeSet (tyVarsOfTypes [k1,k2])) subst
+        k1 = substTy subst_kind (tyVarKind tv1)
+        k2 = substTy subst_kind (tyVarKind tv2)
+        k1_sub_k2 = k1 `isSubKind` k2
+        k2_sub_k1 = k2 `isSubKind` k1
+        ty1 = TyVarTy tv1
+        bind subst tv ty = return $ extendVarEnv subst tv ty
+        choose subst = do
+             { b1 <- tvBindFlag tv1
+             ; b2 <- tvBindFlag tv2
+             ; case (b1, b2) of
+                 (BindMe, _)         -> bind subst tv1 ty2
+                 (Skolem, Skolem)    -> failWith (misMatch ty1 ty2)
+                 (Skolem, _)         -> bind subst tv2 ty1 }
 
 uUnrefined subst tv1 ty2 ty2'	-- ty2 is not a type variable
   | tv1 `elemVarSet` niSubstTvSet subst (tyVarsOfType ty2')