Fix Trac #9071, an egregious bug in TcDeriv.inferConstraints

The constraints for Functor don't line up 1-1 with the arguments
(they are fetched out from sub-terms of the type), but the surrounding
code was mistakenly assuming they were in 1-1 association.

4 files changed, 28 insertions, 23 deletions

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 71fd25c557..23975b9e07 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -1121,21 +1121,23 @@ inferConstraints cls inst_tys rep_tc rep_tc_args
 
   | otherwise  -- The others are a bit more complicated
   = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc )
-    return (stupid_constraints ++ extra_constraints
-            ++ sc_constraints
-            ++ con_arg_constraints cls get_std_constrained_tys)
-
+    do { traceTc "inferConstraints" (vcat [ppr cls <+> ppr inst_tys, ppr arg_constraints])
+       ; return (stupid_constraints ++ extra_constraints
+                 ++ sc_constraints
+                 ++ arg_constraints) }
   where
+    arg_constraints = con_arg_constraints cls get_std_constrained_tys
+
        -- Constraints arising from the arguments of each constructor
     con_arg_constraints cls' get_constrained_tys
-      = [ mkPredOrigin (DerivOriginDC data_con arg_n) (mkClassPred cls' [arg_ty])
-        | data_con <- tyConDataCons rep_tc,
-          (arg_n, arg_ty) <-
-                ASSERT( isVanillaDataCon data_con )
-                zip [1..] $  -- ASSERT is precondition of dataConInstOrigArgTys
-                get_constrained_tys $
-                dataConInstOrigArgTys data_con all_rep_tc_args,
-          not (isUnLiftedType arg_ty) ]
+      = [ mkPredOrigin (DerivOriginDC data_con arg_n) (mkClassPred cls' [inner_ty])
+        | data_con <- tyConDataCons rep_tc
+        , (arg_n, arg_ty) <- ASSERT( isVanillaDataCon data_con )
+                             zip [1..] $  -- ASSERT is precondition of dataConInstOrigArgTys
+                             dataConInstOrigArgTys data_con all_rep_tc_args
+        , not (isUnLiftedType arg_ty)
+        , inner_ty <- get_constrained_tys arg_ty ]
+
                 -- No constraints for unlifted types
                 -- See Note [Deriving and unboxed types]
 
@@ -1145,10 +1147,10 @@ inferConstraints cls inst_tys rep_tc rep_tc_args
                 -- (b) The rep_tc_args will be one short
     is_functor_like = getUnique cls `elem` functorLikeClassKeys
 
-    get_std_constrained_tys :: [Type] -> [Type]
-    get_std_constrained_tys tys
-        | is_functor_like = concatMap (deepSubtypesContaining last_tv) tys
-        | otherwise       = tys
+    get_std_constrained_tys :: Type -> [Type]
+    get_std_constrained_tys ty
+        | is_functor_like = deepSubtypesContaining last_tv ty
+        | otherwise       = [ty]
 
     rep_tc_tvs = tyConTyVars rep_tc
     last_tv = last rep_tc_tvs
diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs
index d9d92ba2ea..35bf4245dc 100644
--- a/compiler/typecheck/TcGenGenerics.lhs
+++ b/compiler/typecheck/TcGenGenerics.lhs
@@ -189,14 +189,13 @@ metaTyConsToDerivStuff tc metaDts =
 %************************************************************************
 
 \begin{code}
-get_gen1_constrained_tys :: TyVar -> [Type] -> [Type]
+get_gen1_constrained_tys :: TyVar -> Type -> [Type]
 -- called by TcDeriv.inferConstraints; generates a list of types, each of which
 -- must be a Functor in order for the Generic1 instance to work.
-get_gen1_constrained_tys argVar =
-  concatMap $ argTyFold argVar $ ArgTyAlg {
-    ata_rec0 = const [],
-    ata_par1 = [], ata_rec1 = const [],
-    ata_comp = (:)}
+get_gen1_constrained_tys argVar
+  = argTyFold argVar $ ArgTyAlg { ata_rec0 = const []
+                                , ata_par1 = [], ata_rec1 = const []
+                                , ata_comp = (:) }
 
 {-
 
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index f3df0bf203..d59876469f 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -1848,7 +1848,8 @@ pprO TupleOrigin           = ptext (sLit "a tuple")
 pprO NegateOrigin          = ptext (sLit "a use of syntactic negation")
 pprO ScOrigin              = ptext (sLit "the superclasses of an instance declaration")
 pprO DerivOrigin           = ptext (sLit "the 'deriving' clause of a data type declaration")
-pprO (DerivOriginDC dc n)  = hsep [ ptext (sLit "the"), speakNth n,
+pprO (DerivOriginDC dc n)  = pprTrace "dco" (ppr dc <+> ppr n) $ 
+                             hsep [ ptext (sLit "the"), speakNth n,
                                     ptext (sLit "field of"), quotes (ppr dc),
                                     parens (ptext (sLit "type") <+> quotes (ppr ty)) ]
     where ty = dataConOrigArgTys dc !! (n-1)
diff --git a/testsuite/tests/deriving/should_fail/all.T b/testsuite/tests/deriving/should_fail/all.T
index d503b6e266..99da88a55b 100644
--- a/testsuite/tests/deriving/should_fail/all.T
+++ b/testsuite/tests/deriving/should_fail/all.T
@@ -50,3 +50,6 @@ test('T7800', normal, multimod_compile_fail, ['T7800',''])
 test('T5498', normal, compile_fail, [''])
 test('T6147', normal, compile_fail, [''])
 test('T8851', normal, compile_fail, [''])
+test('T9071', normal, multimod_compile_fail, ['T9071',''])
+test('T9071_2', normal, compile_fail, [''])
+