diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2011-05-04 13:27:12 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2011-05-04 13:27:12 +0100 |
| commit | a10a21dadac041e928ad5dab3810b68ab35bc9bb (patch) | |
| tree | c51298b42fa17a5455c5195edd53408fc3b28e29 | |
| parent | 5096055e9aa46a7cc8b5a1292f7094fe588ec4d1 (diff) | |
| download | haskell-a10a21dadac041e928ad5dab3810b68ab35bc9bb.tar.gz | |
Be cleverer in dataConCannotMatch, fixes Trac #5168
| -rw-r--r-- | compiler/basicTypes/DataCon.lhs | 11 | ||||
| -rw-r--r-- | compiler/types/Unify.lhs | 7 |
2 files changed, 9 insertions, 9 deletions
diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 5e359848e2..458bfd3f81 100644 --- 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 --- +-- NB: look at *all* equality constraints, not only those +-- in dataConEqSpec; see Trac #5168 dataConCannotMatch tys con - | null eq_spec = False -- Common + | null theta = False -- Common | 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 - eq_spec = dataConEqSpec con + theta = dataConTheta con subst = zipTopTvSubst dc_tvs tys \end{code} diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs index 38507830ab..9c448ce065 100644 --- 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} -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 @@ -330,7 +329,7 @@ typesCantMatch tys1 tys2 = ASSERT( equalLength tys1 tys2 ) 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 |