Fix a bug in functorLikeTraverse, which was giving wrong answer for tuples

This bug led to Trac #4816, which is hereby fixed

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 88236a6..2988f08 100644 (file)
--- 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 54d786f..2c04cf4 100644 (file)
--- 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