| otherwise
= do { dfun_name <- new_dfun_name cls tycon
; loc <- getSrcSpanM
- ; let ordinary_constraints_simple
- = [ mkClassPred cls [arg_ty]
- | data_con <- tyConDataCons rep_tc,
- arg_ty <- ASSERT( isVanillaDataCon data_con )
- dataConInstOrigArgTys data_con rep_tc_args,
- not (isUnLiftedType arg_ty) ]
- -- No constraints for unlifted types
- -- Where they are legal we generate specilised function calls
-
- -- constraints on all subtypes for classes like Functor
- ordinary_constraints_deep
- = [ mkClassPred cls [deept_ty]
- | data_con <- tyConDataCons rep_tc,
- arg_ty <- ASSERT( isVanillaDataCon data_con )
- dataConInstOrigArgTys data_con (rep_tc_args++[mkTyVarTy dummy_ty]),
- deept_ty <- deepSubtypesContaining dummy_ty arg_ty,
- not (isUnLiftedType deept_ty) ]
- where dummy_ty = last (tyConTyVars tycon) -- don't substitute the last var, this might not be a good idea
-
- ordinary_constraints
- | getUnique cls == functorClassKey = ordinary_constraints_deep
- | getUnique cls == foldableClassKey = ordinary_constraints_deep
- | getUnique cls == traversableClassKey = ordinary_constraints_deep
- | otherwise = ordinary_constraints_simple
-
- -- See Note [Superclasses of derived instance]
- sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys)
- (classSCTheta cls)
- inst_tys = [mkTyConApp tycon tc_args]
-
- nonfree_tycon_vars = dropTail (classArity cls) (tyConTyVars rep_tc)
- stupid_subst = zipTopTvSubst nonfree_tycon_vars rep_tc_args
- stupid_constraints = substTheta stupid_subst (tyConStupidTheta rep_tc)
-
- all_constraints = stupid_constraints ++ sc_constraints ++ ordinary_constraints
-
+ ; let inst_tys = [mkTyConApp tycon tc_args]
+ inferred_constraints = inferConstraints tvs cls inst_tys rep_tc rep_tc_args
spec = DS { ds_loc = loc, ds_orig = orig
, ds_name = dfun_name, ds_tvs = tvs
, ds_cls = cls, ds_tys = inst_tys
, ds_tc = rep_tc, ds_tc_args = rep_tc_args
- , ds_theta = mtheta `orElse` all_constraints
+ , ds_theta = mtheta `orElse` inferred_constraints
, ds_newtype = False }
; return (if isJust mtheta then Right spec -- Specified context
, ds_theta = mtheta `orElse` [], ds_newtype = False }) }
+inferConstraints :: [TyVar] -> Class -> [TcType] -> TyCon -> [TcType] -> ThetaType
+-- Generate a sufficiently large set of constraints that typechecking the
+-- generated method definitions should succeed. This set will be simplified
+-- before being used in the instance declaration
+inferConstraints tvs cls inst_tys rep_tc rep_tc_args
+ = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc )
+ stupid_constraints ++ extra_constraints
+ ++ sc_constraints ++ con_arg_constraints
+ where
+ -- Constraints arising from the arguments of each constructor
+ con_arg_constraints
+ = [ mkClassPred cls [arg_ty]
+ | data_con <- tyConDataCons rep_tc,
+ arg_ty <- ASSERT( isVanillaDataCon data_con )
+ get_constrained_tys $
+ dataConInstOrigArgTys data_con all_rep_tc_args,
+ not (isUnLiftedType arg_ty) ]
+ -- No constraints for unlifted types
+ -- Where they are legal we generate specilised function calls
+
+ -- For functor-like classes, two things are different
+ -- (a) We recurse over argument types to generate constraints
+ -- See Functor examples in TcGenDeriv
+ -- (b) The rep_tc_args will be one short
+ is_functor_like = getUnique cls `elem` functorLikeClassKeys
+
+ get_constrained_tys :: [Type] -> [Type]
+ get_constrained_tys tys
+ | is_functor_like = concatMap (deepSubtypesContaining last_tv) tys
+ | otherwise = tys
+
+ rep_tc_tvs = tyConTyVars rep_tc
+ last_tv = last rep_tc_tvs
+ all_rep_tc_args | is_functor_like = rep_tc_args ++ [mkTyVarTy last_tv]
+ | otherwise = rep_tc_args
+
+ -- Constraints arising from superclasses
+ -- See Note [Superclasses of derived instance]
+ sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys)
+ (classSCTheta cls)
+
+ -- Stupid constraints
+ stupid_constraints = substTheta subst (tyConStupidTheta rep_tc)
+ subst = zipTopTvSubst rep_tc_tvs all_rep_tc_args
+
+ -- Extra constraints
+ -- The Data class (only) requires that for
+ -- instance (...) => Data (T a b)
+ -- then (Data a, Data b) are among the (...) constraints
+ -- Reason: that's what you need to typecheck the method
+ -- dataCast1 f = gcast1 f
+ extra_constraints
+ | cls `hasKey` dataClassKey = [mkClassPred cls [mkTyVarTy tv] | tv <- tvs]
+ | otherwise = []
+
------------------------------------------------------------------
-- Check side conditions that dis-allow derivability for particular classes
-- This is *apart* from the newtype-deriving mechanism
sideConditions :: Class -> Maybe Condition
sideConditions cls
- | cls_key == eqClassKey = Just cond_std
- | cls_key == ordClassKey = Just cond_std
- | cls_key == showClassKey = Just cond_std
- | cls_key == readClassKey = Just (cond_std `andCond` cond_noUnliftedArgs)
- | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration)
- | cls_key == ixClassKey = Just (cond_std `andCond` cond_enumOrProduct)
- | cls_key == boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct)
- | cls_key == dataClassKey = Just (cond_mayDeriveDataTypeable `andCond` cond_std `andCond` cond_noUnliftedArgs)
- | cls_key == functorClassKey = Just (cond_mayDeriveFunctor `andCond` cond_std `andCond` cond_functorOK True)
- | cls_key == foldableClassKey = Just (cond_mayDeriveFunctor `andCond` cond_std `andCond` cond_functorOK False)
- | cls_key == traversableClassKey = Just (cond_mayDeriveFunctor `andCond` cond_std `andCond` cond_functorOK False)
+ | cls_key == eqClassKey = Just cond_std
+ | cls_key == ordClassKey = Just cond_std
+ | cls_key == showClassKey = Just cond_std
+ | cls_key == readClassKey = Just (cond_std `andCond` cond_noUnliftedArgs)
+ | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration)
+ | cls_key == ixClassKey = Just (cond_std `andCond` cond_enumOrProduct)
+ | cls_key == boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct)
+ | cls_key == dataClassKey = Just (cond_mayDeriveDataTypeable `andCond` cond_std `andCond` cond_noUnliftedArgs)
+ | cls_key == functorClassKey = Just (cond_std `andCond` cond_functorOK True)
+ | cls_key == foldableClassKey = Just (cond_std `andCond` cond_functorOK False)
+ | cls_key == traversableClassKey = Just (cond_std `andCond` cond_functorOK False)
| getName cls `elem` typeableClassNames = Just (cond_mayDeriveDataTypeable `andCond` cond_typeableOK)
| otherwise = Nothing
where
fam_inst = quotes (pprSourceTyCon rep_tc) <+>
ptext (sLit "is a type family")
+
+functorLikeClassKeys :: [Unique]
+functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey]
+
cond_functorOK :: Bool -> Condition
-- OK for Functor class
-- Currently: (a) at least one argument
-- (b) don't use argument contravariantly
-- (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
-- (d) optionally: don't use function types
-cond_functorOK allowFunctions (_, rep_tc) = msum (map check con_types)
+cond_functorOK allowFunctions (dflags, rep_tc)
+ | not (dopt Opt_DeriveFunctor dflags)
+ = Just (ptext (sLit "You need -XDeriveFunctor to derive an instance for this class"))
+ | otherwise
+ = msum (map check_con data_cons) -- msum picks the first 'Just', if any
where
data_cons = tyConDataCons rep_tc
- con_types = concatMap dataConOrigArgTys data_cons
- check = functorLikeTraverse
- Nothing
- Nothing
- (Just covariant)
- (\x y -> if allowFunctions then x `mplus` y else Just functions)
- (\_ xs -> msum xs)
- (\_ x -> x)
- (Just wrong_arg)
- (\_ x -> x)
- (last (tyConTyVars rep_tc))
+ check_con con = msum (foldDataConArgs ft_check con)
+
+ ft_check :: FFoldType (Maybe SDoc)
+ ft_check = FT { ft_triv = Nothing, ft_var = Nothing, ft_co_var = Just covariant
+ , ft_fun = \x y -> if allowFunctions then x `mplus` y else Just functions
+ , ft_tup = \_ xs -> msum xs
+ , ft_ty_app = \_ x -> x
+ , ft_bad_app = Just wrong_arg
+ , ft_forall = \_ x -> x }
+
covariant = quotes (pprSourceTyCon rep_tc) <+>
ptext (sLit "uses the type variable in a function argument")
functions = quotes (pprSourceTyCon rep_tc) <+>
where
why = ptext (sLit "You need -XDeriveDataTypeable to derive an instance for this class")
-cond_mayDeriveFunctor :: Condition
-cond_mayDeriveFunctor (dflags, _)
- | dopt Opt_DeriveFunctor dflags = Nothing
- | otherwise = Just why
- where
- why = ptext (sLit "You need -XDeriveFunctor to derive an instance for this class")
-
std_class_via_iso :: Class -> Bool
std_class_via_iso clas -- These standard classes can be derived for a newtype
-- using the isomorphism trick *even if no -fglasgow-exts*
- = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
+ = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
-- Not Read/Show because they respect the type
-- Not Enum, because newtypes are never in Enum