Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : ghc-kinds
http://hackage.haskell.org/trac/ghc/changeset/01ba4e3243491b4569098a1c58c110c2a4806ed7 >--------------------------------------------------------------- commit 01ba4e3243491b4569098a1c58c110c2a4806ed7 Author: Julien Cretin <g...@ia0.eu> Date: Fri Sep 23 11:33:17 2011 +0200 kind substitution in tcExpr (RecordUpd {}) >--------------------------------------------------------------- compiler/typecheck/TcCanonical.lhs | 2 +- compiler/typecheck/TcExpr.lhs | 19 ++++++++++++++----- compiler/typecheck/TcSimplify.lhs | 5 +++-- compiler/typecheck/TcTyClsDecls.lhs | 2 +- compiler/types/Kind.lhs | 9 +++++---- compiler/types/Type.lhs | 4 ++-- 6 files changed, 26 insertions(+), 15 deletions(-) diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index b2514b5..eb018f9 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -1037,7 +1037,7 @@ instFunDepEqn :: WantedLoc -> Equation -> TcS [(Int,(EvVar,WantedLoc))] instFunDepEqn wl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs , fd_pred1 = d1, fd_pred2 = d2 }) = do { let tvs = varSetElems qtvs - ; tvs' <- mapM instFlexiTcS tvs + ; tvs' <- mapM instFlexiTcS tvs -- IA0_TODO: we might need to do kind substitution ; let subst = zipTopTvSubst tvs (mkTyVarTys tvs') ; foldM (do_one subst) [] eqs } where diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index fcc8e30..1562e4a 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -42,6 +42,7 @@ import DataCon import Name import TyCon import Type +import Kind( splitKiTyVars ) import Coercion import Var import VarSet @@ -636,16 +637,24 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty -- ; let fixed_tvs = getFixedTyVars con1_tvs relevant_cons is_fixed_tv tv = tv `elemVarSet` fixed_tvs - mk_inst_ty tv result_inst_ty + mk_inst_ty subst tv result_inst_ty | is_fixed_tv tv = return result_inst_ty -- Same as result type - | otherwise = newFlexiTyVarTy (tyVarKind tv) -- Fresh type, of correct kind + | otherwise = newFlexiTyVarTy (subst (tyVarKind tv)) -- Fresh type, of correct kind ; (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tvs - ; scrut_inst_tys <- zipWithM mk_inst_ty con1_tvs result_inst_tys - ; let rec_res_ty = TcType.substTy result_inst_env con1_res_ty + ; let (con1_r_kvs, con1_r_tvs) = splitKiTyVars con1_tvs + n_kinds = length con1_r_kvs + (result_inst_r_kis, result_inst_r_tys) = splitAt n_kinds result_inst_tys + ; scrut_inst_r_kis <- zipWithM (mk_inst_ty (TcType.substTy (zipTopTvSubst [] []))) con1_r_kvs result_inst_r_kis + -- IA0_NOTE: we have to build the kind substitution + ; let kind_subst = TcType.substTy (zipTopTvSubst con1_r_kvs scrut_inst_r_kis) + ; scrut_inst_r_tys <- zipWithM (mk_inst_ty kind_subst) con1_r_tvs result_inst_r_tys + + ; let scrut_inst_tys = scrut_inst_r_kis ++ scrut_inst_r_tys + rec_res_ty = TcType.substTy result_inst_env con1_res_ty con1_arg_tys' = map (TcType.substTy result_inst_env) con1_arg_tys - scrut_subst = zipTopTvSubst con1_tvs scrut_inst_tys + scrut_subst = zipTopTvSubst con1_tvs scrut_inst_tys scrut_ty = TcType.substTy scrut_subst con1_res_ty ; co_res <- unifyType rec_res_ty res_ty diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 064545d..3db4667 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -21,6 +21,7 @@ import VarSet import VarEnv import Coercion import TypeRep +import Type ( varSetElemsKvsFirst ) import Name import NameEnv ( emptyNameEnv ) @@ -220,7 +221,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds = do { gbl_tvs <- tcGetGlobalTyVars -- Already zonked ; zonked_taus <- zonkTcTypes (map snd name_taus) ; let tvs_to_quantify = get_tau_tvs zonked_taus `minusVarSet` gbl_tvs - ; qtvs <- zonkQuantifiedTyVars (varSetElems tvs_to_quantify) + ; qtvs <- zonkQuantifiedTyVars (varSetElemsKvsFirst tvs_to_quantify) ; return (qtvs, [], False, emptyTcEvBinds) } | otherwise @@ -305,7 +306,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds -- tidied uniformly ; gloc <- getCtLoc skol_info - ; qtvs_to_return <- zonkQuantifiedTyVars (varSetElems qtvs) + ; qtvs_to_return <- zonkQuantifiedTyVars (varSetElemsKvsFirst qtvs) -- Step 5 -- Minimize `bound' and emit an implication diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 8bf58f0..916d5c6 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -1237,7 +1237,7 @@ checkValidClass cls } where (tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls - unary = isSingleton (snd (splitKiTyVars tyvars)) -- only count type arguments + unary = isSingleton (snd (splitKiTyVars tyvars)) -- IA0_NOTE: only count type arguments no_generics = null [() | (_, (GenDefMeth _)) <- op_stuff] check_op constrained_class_methods (sel_id, dm) diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs index ca7e08a..c9aa692 100644 --- a/compiler/types/Kind.lhs +++ b/compiler/types/Kind.lhs @@ -35,7 +35,7 @@ module Kind ( isSubKindCon, isSubOpenTypeKindCon, -- ** Functions on variables - splitKiTyVars, + splitKiTyVars, partitionKiTyVars, -- ** Promotion related functions promoteType, isPromotableType, isPromotableKind @@ -235,9 +235,10 @@ defaultKind k | otherwise = k splitKiTyVars :: [TyVar] -> ([KindVar], [TyVar]) --- We use partition and not span because sometimes the list we get --- comes from a varSetElems -splitKiTyVars = partition (isSuperKind . tyVarKind) +splitKiTyVars = span (isSuperKind . tyVarKind) + +partitionKiTyVars :: [TyVar] -> ([KindVar], [TyVar]) +partitionKiTyVars = partition (isSuperKind . tyVarKind) -- About promoting a type to a kind diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 5330acc..3383064 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -138,7 +138,7 @@ module Type ( -- We import the representation and primitive functions from TypeRep. -- Many things are reexported, but not the representation! -import Kind ( kindAppResult, isSuperKind, isSubOpenTypeKind, splitKiTyVars ) +import Kind ( kindAppResult, isSuperKind, isSubOpenTypeKind, splitKiTyVars, partitionKiTyVars ) import TypeRep -- friends: @@ -941,7 +941,7 @@ typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) varSetElemsKvsFirst :: VarSet -> [TyVar] -- {k1,a,k2,b} --> [k1,k2,a,b] -varSetElemsKvsFirst set = uncurry (++) $ splitKiTyVars (varSetElems set) +varSetElemsKvsFirst set = uncurry (++) $ partitionKiTyVars (varSetElems set) sortQuantVars :: [Var] -> [Var] -- Sort the variables so the true kind then type variables come first _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
