Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/a62c4375436c6264e5cc98d12cad69709dcc9075 >--------------------------------------------------------------- commit a62c4375436c6264e5cc98d12cad69709dcc9075 Author: Simon Peyton Jones <simo...@microsoft.com> Date: Wed Dec 19 17:36:34 2012 +0000 Add some ASSERTs to calls of zipTopTvSubst >--------------------------------------------------------------- compiler/basicTypes/DataCon.lhs | 5 +++-- compiler/types/FamInstEnv.lhs | 4 +++- compiler/types/Type.lhs | 6 +++--- 3 files changed, 9 insertions(+), 6 deletions(-) diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 18e8c2a..1b14179 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -911,7 +911,7 @@ classDataCon clas = case tyConDataCons (classTyCon clas) of dataConCannotMatch :: [Type] -> DataCon -> Bool -- Returns True iff the data con *definitely cannot* match a -- scrutinee of type (T tys) --- where T is the type constructor for the data con +-- where T is the dcRepTyCon for the data con -- NB: look at *all* equality constraints, not only those -- in dataConEqSpec; see Trac #5168 dataConCannotMatch tys con @@ -923,7 +923,8 @@ dataConCannotMatch tys con where dc_tvs = dataConUnivTyVars con theta = dataConTheta con - subst = zipTopTvSubst dc_tvs tys + subst = ASSERT2( length dc_tvs == length tys, ppr con $$ ppr dc_tvs $$ ppr tys ) + zipTopTvSubst dc_tvs tys -- TODO: could gather equalities from superclasses too predEqs pred = case classifyPredType pred of diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index f30d783..88ab098 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -398,7 +398,9 @@ lookupFamInstEnvConflicts envs fam_inst skol_tvs inst_axiom = famInstAxiom fam_inst (fam, tys) = famInstLHS fam_inst skol_tys = mkTyVarTys skol_tvs - tys1 = substTys (zipTopTvSubst (coAxiomTyVars inst_axiom) skol_tys) tys + ax_tvs = coAxiomTyVars inst_axiom + tys1 = ASSERT2( length ax_tvs == length skol_tys, ppr inst_axiom $$ ppr skol_tys ) + substTys (zipTopTvSubst ax_tvs skol_tys) tys -- In example above, fam tys' = F [b] my_unify old_fam_inst tpl_tvs tpl_tys match_tys diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 3fc1cef..0f1a8be 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -1034,7 +1034,9 @@ mkFamilyTyConApp :: TyCon -> [Type] -> Type -- > mkFamilyTyConApp :RTL Int = T (Maybe Int) mkFamilyTyConApp tc tys | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc - , let fam_subst = zipTopTvSubst (tyConTyVars tc) tys + , let tvs = tyConTyVars tc + fam_subst = ASSERT2( length tvs == length tys, ppr tc <+> ppr tys ) + zipTopTvSubst tvs tys = mkTyConApp fam_tc (substTys fam_subst fam_tys) | otherwise = mkTyConApp tc tys @@ -1615,13 +1617,11 @@ typeKind _ty@(FunTy _arg res) where k = typeKind res - typeLiteralKind :: TyLit -> Kind typeLiteralKind l = case l of NumTyLit _ -> typeNatKind StrTyLit _ -> typeStringKind - \end{code} Kind inference _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
