+
+------------------------------------------------------------------
+mkDataTypeEqn :: TyCon -> Class -> TcM DerivEqn
+mkDataTypeEqn tycon clas
+ | clas `hasKey` typeableClassKey
+ = -- The Typeable class is special in several ways
+ -- data T a b = ... deriving( Typeable )
+ -- gives
+ -- instance Typeable2 T where ...
+ -- Notice that:
+ -- 1. There are no constraints in the instance
+ -- 2. There are no type variables either
+ -- 3. The actual class we want to generate isn't necessarily
+ -- Typeable; it depends on the arity of the type
+ do { real_clas <- tcLookupClass (typeableClassNames !! tyConArity tycon)
+ ; dfun_name <- new_dfun_name real_clas tycon
+ ; return (dfun_name, real_clas, tycon, [], []) }
+
+ | otherwise
+ = do { dfun_name <- new_dfun_name clas tycon
+ ; return (dfun_name, clas, tycon, tyvars, constraints) }
+ where
+ tyvars = tyConTyVars tycon
+ constraints = extra_constraints ++ ordinary_constraints
+ extra_constraints = tyConStupidTheta tycon
+ -- "extra_constraints": see note [Data decl contexts] above
+
+ ordinary_constraints
+ = [ mkClassPred clas [arg_ty]
+ | data_con <- tyConDataCons tycon,
+ arg_ty <- dataConOrigArgTys data_con,
+ not (isUnLiftedType arg_ty) -- No constraints for unlifted types?
+ ]
+
+
+------------------------------------------------------------------
+-- Check side conditions that dis-allow derivability for particular classes
+-- This is *apart* from the newtype-deriving mechanism
+
+checkSideConditions :: Bool -> TyCon -> [TyVar] -> Class -> [TcType] -> Maybe SDoc
+checkSideConditions gla_exts tycon deriv_tvs clas tys
+ | notNull deriv_tvs || notNull tys
+ = Just ty_args_why -- e.g. deriving( Foo s )
+ | otherwise
+ = case [cond | (key,cond) <- sideConditions, key == getUnique clas] of
+ [] -> Just (non_std_why clas)
+ [cond] -> cond (gla_exts, tycon)
+ other -> pprPanic "checkSideConditions" (ppr clas)
+ where
+ ty_args_why = quotes (ppr (mkClassPred clas tys)) <+> ptext SLIT("is not a class")
+
+non_std_why clas = quotes (ppr clas) <+> ptext SLIT("is not a derivable class")
+
+sideConditions :: [(Unique, Condition)]
+sideConditions
+ = [ (eqClassKey, cond_std),
+ (ordClassKey, cond_std),
+ (readClassKey, cond_std),
+ (showClassKey, cond_std),
+ (enumClassKey, cond_std `andCond` cond_isEnumeration),
+ (ixClassKey, cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct)),
+ (boundedClassKey, cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct)),
+ (typeableClassKey, cond_glaExts `andCond` cond_typeableOK),
+ (dataClassKey, cond_glaExts `andCond` cond_std)
+ ]
+
+type Condition = (Bool, TyCon) -> Maybe SDoc -- Nothing => OK
+
+orCond :: Condition -> Condition -> Condition
+orCond c1 c2 tc
+ = case c1 tc of
+ Nothing -> Nothing -- c1 succeeds
+ Just x -> case c2 tc of -- c1 fails
+ Nothing -> Nothing
+ Just y -> Just (x $$ ptext SLIT(" and") $$ y)
+ -- Both fail
+
+andCond c1 c2 tc = case c1 tc of
+ Nothing -> c2 tc -- c1 succeeds
+ Just x -> Just x -- c1 fails
+
+cond_std :: Condition
+cond_std (gla_exts, tycon)
+ | any (not . isVanillaDataCon) data_cons = Just existential_why
+ | null data_cons = Just no_cons_why
+ | otherwise = Nothing
+ where
+ data_cons = tyConDataCons tycon
+ no_cons_why = quotes (ppr tycon) <+> ptext SLIT("has no data constructors")
+ existential_why = quotes (ppr tycon) <+> ptext SLIT("has non-Haskell-98 constructor(s)")
+
+cond_isEnumeration :: Condition
+cond_isEnumeration (gla_exts, tycon)
+ | isEnumerationTyCon tycon = Nothing
+ | otherwise = Just why
+ where
+ why = quotes (ppr tycon) <+> ptext SLIT("has non-nullary constructors")
+
+cond_isProduct :: Condition
+cond_isProduct (gla_exts, tycon)
+ | isProductTyCon tycon = Nothing
+ | otherwise = Just why
+ where
+ why = quotes (ppr tycon) <+> ptext SLIT("has more than one constructor")
+
+cond_typeableOK :: Condition
+-- OK for Typeable class
+-- Currently: (a) args all of kind *
+-- (b) 7 or fewer args
+cond_typeableOK (gla_exts, tycon)
+ | tyConArity tycon > 7 = Just too_many
+ | not (all (isArgTypeKind . tyVarKind) (tyConTyVars tycon)) = Just bad_kind
+ | otherwise = Nothing
+ where
+ too_many = quotes (ppr tycon) <+> ptext SLIT("has too many arguments")
+ bad_kind = quotes (ppr tycon) <+> ptext SLIT("has arguments of kind other than `*'")
+
+cond_glaExts :: Condition
+cond_glaExts (gla_exts, tycon) | gla_exts = Nothing
+ | otherwise = Just why
+ where
+ why = ptext SLIT("You need -fglasgow-exts to derive an instance for this class")