+
+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 (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_types)
+ 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))
+ covariant = quotes (pprSourceTyCon rep_tc) <+>
+ ptext (sLit "uses the type variable in a function argument")
+ functions = quotes (pprSourceTyCon rep_tc) <+>
+ ptext (sLit "contains function types")
+ wrong_arg = quotes (pprSourceTyCon rep_tc) <+>
+ ptext (sLit "uses the type variable in an argument other than the last")
+