[commit: ghc] master: Add some ASSERTs to calls of zipTopTvSubst (a62c437)

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 <[email protected]>
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