diff options
| author | simonpj@microsoft.com <unknown> | 2010-12-15 12:37:25 +0000 |
|---|---|---|
| committer | simonpj@microsoft.com <unknown> | 2010-12-15 12:37:25 +0000 |
| commit | 03edcb58482b016a8ee019a06e114c8e8c996400 (patch) | |
| tree | 92334560e4881cf18b45f43075e1fe1360bee14e | |
| parent | 47673f2f689b0c3294c119afd217afab1044f213 (diff) | |
| download | haskell-03edcb58482b016a8ee019a06e114c8e8c996400.tar.gz | |
Fix a bug in functorLikeTraverse, which was giving wrong answer for tuples
This bug led to Trac #4816, which is hereby fixed
| -rw-r--r-- | compiler/typecheck/TcDeriv.lhs | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcGenDeriv.lhs | 12 |
2 files changed, 8 insertions, 6 deletions
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 88236a6dd3..2988f08a38 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -750,7 +750,7 @@ inferConstraints _ cls inst_tys rep_tc rep_tc_args get_constrained_tys :: [Type] -> [Type] get_constrained_tys tys - | is_functor_like = concatMap (deepSubtypesContaining last_tv) tys + | is_functor_like = concatMap (deepSubtypesContaining last_tv) tys | otherwise = tys rep_tc_tvs = tyConTyVars rep_tc diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 54d786ff9d..2c04cf4bc3 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -1457,11 +1457,13 @@ functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar where (_, xc) = go co x (yr,yc) = go co y go co ty@(TyConApp con args) - | isTupleTyCon con = (caseTuple (tupleTyConBoxity con) xrs,True) - | null args = (caseTrivial,False) -- T - | or (init xcs) = (caseWrongArg,True) -- T (..var..) ty - | last xcs = -- T (..no var..) ty - (caseTyApp (fst (splitAppTy ty)) (last xrs),True) + | not (or xcs) = (caseTrivial, False) -- Variable does not occur + -- At this point we know that xrs, xcs is not empty, + -- and at least one xr is True + | isTupleTyCon con = (caseTuple (tupleTyConBoxity con) xrs, True) + | or (init xcs) = (caseWrongArg, True) -- T (..var..) ty + | otherwise = -- T (..no var..) ty + (caseTyApp (fst (splitAppTy ty)) (last xrs), True) where (xrs,xcs) = unzip (map (go co) args) go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True) where (xr,xc) = go co x |