Commit 13a330e8 authored by Simon Peyton Jones's avatar Simon Peyton Jones

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.
parent 5b73dc5f
......@@ -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
......
......@@ -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 = (:) }
{-
......
......@@ -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)
......
......@@ -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, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment