Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : ghc-kinds
http://hackage.haskell.org/trac/ghc/changeset/57df58a7c7c2fac2beb5c05c3dcc388071c4fa15 >--------------------------------------------------------------- commit 57df58a7c7c2fac2beb5c05c3dcc388071c4fa15 Author: Simon Peyton Jones <[email protected]> Date: Wed Nov 2 09:36:33 2011 +0000 Fix zonkQuantifiedTyVars >--------------------------------------------------------------- compiler/typecheck/TcHsSyn.lhs | 2 +- compiler/typecheck/TcHsType.lhs | 18 ++++++-------- compiler/typecheck/TcMType.lhs | 45 ++++++++++++++----------------------- compiler/typecheck/TcSimplify.lhs | 8 ++---- 4 files changed, 29 insertions(+), 44 deletions(-) diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 806a1d5..d261f8c 100755 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -1196,7 +1196,7 @@ zonkTvCollecting :: TcRef TyVarSet -> UnboundTyVarZonker zonkTvCollecting unbound_tv_set tv = do { poly_kinds <- xoptM Opt_PolyKinds ; if isKiVar tv && not poly_kinds then - do { _ <- defaultKindVarToStar tv + do { defaultKindVarToStar tv ; return liftedTypeKind } else do { tv' <- zonkQuantifiedTyVar tv diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 92fac0b..e135f11 100755 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -964,19 +964,17 @@ kindGeneralizeKinds kinds -- the kinds, and *not* in the environment ; zonked_kinds <- mapM zonkTcKind kinds ; gbl_tvs <- tcGetGlobalTyVars -- Already zonked - ; let kvs_to_quantify = varSetElems (tyVarsOfTypes zonked_kinds - `minusVarSet` gbl_tvs) + ; let kvs_to_quantify = tyVarsOfTypes zonked_kinds + `minusVarSet` gbl_tvs - ; kvs <- ASSERT2 (and (map isKiVar kvs_to_quantify), ppr kvs_to_quantify) + ; kvs <- ASSERT2 (all isKiVar (varSetElems kvs_to_quantify), ppr kvs_to_quantify) zonkQuantifiedTyVars kvs_to_quantify - -- If PolyKinds is off, zonkQuantifiedTyVars will return the empty list - ; poly_kinds <- xoptM Opt_PolyKinds - ; let new_kvs = if poly_kinds then mkTyVarTys kvs - else ASSERT ( null kvs ) - -- In that case, we want to replace by kind * - replicate (length kvs_to_quantify) liftedTypeKind - ; let final_kinds = substKisWith kvs_to_quantify new_kvs zonked_kinds + -- Zonk the kinds again, to pick up either the kind + -- variables we quantify over, or *, depending on whether + -- zonkQuantifiedTyVars decided to generalise (which in + -- turn depends on PolyKinds) + ; final_kinds <- mapM zonkTcKind zonked_kinds ; traceTc "generalizeKind" ( ppr kinds <+> ppr kvs_to_quantify <+> ppr kvs <+> ppr final_kinds) diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs old mode 100755 new mode 100644 index 0cba9d5..529793e --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -54,7 +54,7 @@ module TcMType ( zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkSigTyVar, zonkQuantifiedTyVar, zonkQuantifiedTyVars, zonkTcType, zonkTcTypes, zonkTcThetaType, - zonkTcKind, defaultKindVarToStar, defaultKindVarsToStar, + zonkTcKind, defaultKindVarToStar, zonkImplication, zonkEvVar, zonkWantedEvVar, zonkFlavoredEvVar, zonkWC, zonkWantedEvVars, zonkTcTypeAndSubst, @@ -96,7 +96,7 @@ import Unique( Unique ) import Bag import Control.Monad -import Data.List ( (\\) ) +import Data.List ( (\\), partition ) \end{code} @@ -568,31 +568,21 @@ zonkTcPredType = zonkTcType are used at the end of type checking \begin{code} -defaultKindVarToStar :: TcTyVar -> TcM TcTyVar -defaultKindVarToStar kv = ASSERT ( isKiVar kv ) - zonkTyVarKind (setTyVarKind kv liftedTypeKind) - -defaultKindVarsToStar :: [TcTyVar] -> TcM [TcTyVar] -defaultKindVarsToStar = mapM defaultKindVarToStar - -checkKiVarsBeforeTys :: [TcTyVar] -> Bool -checkKiVarsBeforeTys = go emptyVarSet where - go _kiVars [] = True - go kiVars (v:vs) - | isKiVar v = go (extendVarSet kiVars v) vs - | isTyVar v = kiVarsOfKind (tyVarKind v) `intersectVarSet` kiVars == kiVars - && go kiVars vs - | otherwise = panic "checkKiVarsBeforeTys" - -zonkQuantifiedTyVars :: [TcTyVar] -> TcM [TcTyVar] +defaultKindVarToStar :: TcTyVar -> TcM () +-- We have a meta-kind: unify it with '*' +defaultKindVarToStar kv + = ASSERT ( isKiVar kv && isMetaTyVar kv ) + writeMetaKindVar kv liftedTypeKind + +zonkQuantifiedTyVars :: TcTyVarSet -> TcM [TcTyVar] -- Precondition: a kind variable occurs before a type -- variable mentioning it in its kind zonkQuantifiedTyVars tyvars - = do { poly_kinds <- xoptM Opt_PolyKinds - ; ASSERT ( checkKiVarsBeforeTys tyvars ) - if poly_kinds then - mapM zonkQuantifiedTyVar tyvars - -- Because of the precondition, any kind variables + = do { let (kvs, tvs) = partitionKiTyVars (varSetElems tyvars) + ; poly_kinds <- xoptM Opt_PolyKinds + ; if poly_kinds then + mapM zonkQuantifiedTyVar (kvs ++ tvs) + -- Because of the order, any kind variables -- mentioned in the kinds of the type variables refer to -- the now-quantified versions else @@ -600,10 +590,9 @@ zonkQuantifiedTyVars tyvars -- to *, and zonk the tyvars as usual. Notice that this -- may make zonkQuantifiedTyVars return a shorter list -- than it was passed, but that's ok - do { _ <- defaultKindVarsToStar kvs - ; mapM zonkQuantifiedTyVar tvs } } - where - (kvs, tvs) = partitionKiTyVars tyvars + do { let (meta_kvs, skolem_kvs) = partition isMetaTyVar kvs + ; mapM_ defaultKindVarToStar meta_kvs + ; mapM zonkQuantifiedTyVar (skolem_kvs ++ tvs) } } zonkQuantifiedTyVar :: TcTyVar -> TcM TcTyVar -- The quantified type variables often include meta type variables diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index c715c75..4b67588 100755 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -21,8 +21,6 @@ import VarSet import VarEnv import Coercion import TypeRep -import Type ( varSetElemsKvsFirst ) - import Name import NameEnv ( emptyNameEnv ) import Bag @@ -235,7 +233,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds ; let tvs_to_quantify = tyVarsOfTypes zonked_taus `minusVarSet` gbl_tvs -- tvs_to_quantify can contain both kind and type vars -- See Note [Which variables to quantify] - ; qtvs <- zonkQuantifiedTyVars (varSetElemsKvsFirst tvs_to_quantify) + ; qtvs <- zonkQuantifiedTyVars tvs_to_quantify ; return (qtvs, [], False, emptyTcEvBinds) } | otherwise @@ -319,8 +317,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds -- they are also bound in ic_skols and we want them to be -- tidied uniformly - ; gloc <- getCtLoc skol_info - ; qtvs_to_return <- zonkQuantifiedTyVars (varSetElemsKvsFirst qtvs) + ; qtvs_to_return <- zonkQuantifiedTyVars qtvs -- Step 5 -- Minimize `bound' and emit an implication @@ -328,6 +325,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds ; ev_binds_var <- newTcEvBinds ; mapBagM_ (\(EvBind evar etrm) -> addTcEvBind ev_binds_var evar etrm) tc_binds0 ; lcl_env <- getLclTypeEnv + ; gloc <- getCtLoc skol_info ; let implic = Implic { ic_untch = NoUntouchables , ic_env = lcl_env , ic_skols = mkVarSet qtvs_to_return _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
