diff options
Diffstat (limited to 'compiler/coreSyn/CoreUtils.lhs')
| -rw-r--r-- | compiler/coreSyn/CoreUtils.lhs | 30 |
1 files changed, 19 insertions, 11 deletions
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 6bcf3fbde4..c4b3019485 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -67,6 +67,7 @@ import Util import Pair import Data.Word import Data.Bits +import Data.List ( mapAccumL ) \end{code} @@ -1064,9 +1065,10 @@ dataConInstPat :: [FastString] -- A long enough list of FSs to use for -- -- where the double-primed variables are created with the FastStrings and -- Uniques given as fss and us -dataConInstPat fss uniqs con inst_tys - = (ex_bndrs, arg_ids) - where +dataConInstPat fss uniqs con inst_tys + = ASSERT( univ_tvs `equalLength` inst_tys ) + (ex_bndrs, arg_ids) + where univ_tvs = dataConUnivTyVars con ex_tvs = dataConExTyVars con arg_tys = dataConRepArgTys con @@ -1077,19 +1079,25 @@ dataConInstPat fss uniqs con inst_tys (ex_uniqs, id_uniqs) = splitAt n_ex uniqs (ex_fss, id_fss) = splitAt n_ex fss - -- Make existential type variables - ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_fss ex_tvs - mk_ex_var uniq fs var = mkTyVar new_name kind + -- Make the instantiating substitution for universals + univ_subst = zipOpenTvSubst univ_tvs inst_tys + + -- Make existential type variables, applyingn and extending the substitution + (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst + (zip3 ex_tvs ex_fss ex_uniqs) + + mk_ex_var :: TvSubst -> (TyVar, FastString, Unique) -> (TvSubst, TyVar) + mk_ex_var subst (tv, fs, uniq) = (Type.extendTvSubst subst tv (mkTyVarTy new_tv) + , new_tv) where + new_tv = mkTyVar new_name kind new_name = mkSysTvName uniq fs - kind = tyVarKind var - - -- Make the instantiating substitution - subst = zipOpenTvSubst (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs) + kind = Type.substTy subst (tyVarKind tv) -- Make value vars, instantiating types - mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (Type.substTy subst ty) noSrcSpan arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys + mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq + (Type.substTy full_subst ty) noSrcSpan \end{code} %************************************************************************ |