Be cleverer in dataConCannotMatch, fixes Trac #5168

diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index 5e35984..458bfd3 100644 (file)
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -835,16 +835,17 @@ 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
 -- 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

---
+-- NB: look at *all* equality constraints, not only those
+--     in dataConEqSpec; see Trac #5168

 dataConCannotMatch tys con
 dataConCannotMatch tys con

-  | null eq_spec      = False  -- Common
+  | null theta        = False  -- Common

   | all isTyVarTy tys = False  -- Also common
   | otherwise
   | all isTyVarTy tys = False  -- Also common
   | otherwise

-  = typesCantMatch (map (substTyVar subst . fst) eq_spec)
-                  (map snd eq_spec)
+  = typesCantMatch [(Type.substTy subst ty1, Type.substTy subst ty2)
+                   | EqPred ty1 ty2 <- theta ]

   where
     dc_tvs  = dataConUnivTyVars con
   where
     dc_tvs  = dataConUnivTyVars con

-    eq_spec = dataConEqSpec con
+    theta   = dataConTheta con

     subst   = zipTopTvSubst dc_tvs tys
 \end{code}
 
     subst   = zipTopTvSubst dc_tvs tys
 \end{code}
 

diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs
index 3850783..9c448ce 100644 (file)
--- a/compiler/types/Unify.lhs
+++ b/compiler/types/Unify.lhs
@@ -316,9 +316,8 @@ anything, type functions (incl newtypes) match anything, and only
 distinct data types fail to match.  We can elaborate later.
 
 \begin{code}
 distinct data types fail to match.  We can elaborate later.
 
 \begin{code}

-typesCantMatch :: [Type] -> [Type] -> Bool
-typesCantMatch tys1 tys2 = ASSERT( equalLength tys1 tys2 )
-                          or (zipWith cant_match tys1 tys2)
+typesCantMatch :: [(Type,Type)] -> Bool
+typesCantMatch prs = any (\(s,t) -> cant_match s t) prs

   where
     cant_match :: Type -> Type -> Bool
     cant_match t1 t2
   where
     cant_match :: Type -> Type -> Bool
     cant_match t1 t2

@@ -330,7 +329,7 @@ typesCantMatch tys1 tys2 = ASSERT( equalLength tys1 tys2 )
 
     cant_match (TyConApp tc1 tys1) (TyConApp tc2 tys2)
        | isDataTyCon tc1 && isDataTyCon tc2
 
     cant_match (TyConApp tc1 tys1) (TyConApp tc2 tys2)
        | isDataTyCon tc1 && isDataTyCon tc2

-       = tc1 /= tc2 || typesCantMatch tys1 tys2
+       = tc1 /= tc2 || typesCantMatch (zipEqual "typesCantMatch" tys1 tys2)

 
     cant_match (FunTy {}) (TyConApp tc _) = isDataTyCon tc
     cant_match (TyConApp tc _) (FunTy {}) = isDataTyCon tc
 
     cant_match (FunTy {}) (TyConApp tc _) = isDataTyCon tc
     cant_match (TyConApp tc _) (FunTy {}) = isDataTyCon tc