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 <g...@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') _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
