+mk_data_eqn, mk_typeable_eqn
+ :: InstOrigin -> [TyVar] -> Class
+ -> TyCon -> [TcType] -> TyCon -> [TcType] -> Maybe ThetaType
+ -> TcM (Maybe EarlyDerivSpec)
+mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
+ | getName cls `elem` typeableClassNames
+ = mk_typeable_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
+
+ | otherwise
+ = do { dfun_name <- new_dfun_name cls tycon
+ ; loc <- getSrcSpanM
+ ; let ordinary_constraints
+ = [ 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?
+
+ -- See Note [Superclasses of derived instance]
+ sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys)
+ (classSCTheta cls)
+ inst_tys = [mkTyConApp tycon tc_args]
+
+ stupid_subst = zipTopTvSubst (tyConTyVars rep_tc) rep_tc_args
+ stupid_constraints = substTheta stupid_subst (tyConStupidTheta rep_tc)
+ all_constraints = stupid_constraints ++ sc_constraints ++ ordinary_constraints
+
+ spec = DS { ds_loc = loc, ds_orig = orig
+ , ds_name = dfun_name, ds_tvs = tvs
+ , ds_cls = cls, ds_tys = inst_tys
+ , ds_theta = mtheta `orElse` all_constraints
+ , ds_newtype = False }
+
+ ; return (if isJust mtheta then Just (Right spec) -- Specified context
+ else Just (Left spec)) } -- Infer context
+
+mk_typeable_eqn orig tvs cls tycon tc_args rep_tc _rep_tc_args mtheta
+ -- 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
+ | isNothing mtheta -- deriving on a data type decl
+ = do { checkTc (cls `hasKey` typeableClassKey)
+ (ptext (sLit "Use deriving( Typeable ) on a data type declaration"))
+ ; real_cls <- tcLookupClass (typeableClassNames !! tyConArity tycon)
+ ; mk_typeable_eqn orig tvs real_cls tycon [] rep_tc [] (Just []) }
+
+ | otherwise -- standaone deriving
+ = do { checkTc (null tc_args)
+ (ptext (sLit "Derived typeable instance must be of form (Typeable")
+ <> int (tyConArity tycon) <+> ppr tycon <> rparen)
+ ; dfun_name <- new_dfun_name cls tycon
+ ; loc <- getSrcSpanM
+ ; return (Just $ Right $
+ DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = []
+ , ds_cls = cls, ds_tys = [mkTyConApp tycon []]
+ , ds_theta = mtheta `orElse` [], ds_newtype = False }) }
+
+------------------------------------------------------------------
+-- Check side conditions that dis-allow derivability for particular classes
+-- This is *apart* from the newtype-deriving mechanism
+--
+-- Here we get the representation tycon in case of family instances as it has
+-- the data constructors - but we need to be careful to fall back to the
+-- family tycon (with indexes) in error messages.
+
+data DerivStatus = CanDerive
+ | NonDerivableClass
+ | DerivableClassError SDoc
+
+checkSideConditions :: Bool -> Class -> [TcType] -> TyCon -> DerivStatus
+checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc
+ | notNull cls_tys
+ = DerivableClassError ty_args_why -- e.g. deriving( Foo s )
+ | otherwise
+ = case sideConditions cls of
+ Nothing -> NonDerivableClass
+ Just cond -> case (cond (mayDeriveDataTypeable, rep_tc)) of
+ Nothing -> CanDerive
+ Just err -> DerivableClassError err
+ where
+ ty_args_why = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class")
+
+nonStdErr :: Class -> SDoc
+nonStdErr cls = quotes (ppr cls) <+> ptext (sLit "is not a derivable class")
+
+sideConditions :: Class -> Maybe Condition
+sideConditions cls
+ | cls_key == eqClassKey = Just cond_std
+ | cls_key == ordClassKey = Just cond_std
+ | cls_key == readClassKey = Just cond_std
+ | cls_key == showClassKey = Just cond_std
+ | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration)
+ | cls_key == ixClassKey = Just (cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct))
+ | cls_key == boundedClassKey = Just (cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct))
+ | cls_key == dataClassKey = Just (cond_mayDeriveDataTypeable `andCond` cond_std)
+ | getName cls `elem` typeableClassNames = Just (cond_mayDeriveDataTypeable `andCond` cond_typeableOK)
+ | otherwise = Nothing
+ where
+ cls_key = getUnique cls
+
+type Condition = (Bool, TyCon) -> Maybe SDoc
+ -- Bool is whether or not we are allowed to derive Data and Typeable
+ -- TyCon is the *representation* tycon if the
+ -- data type is an indexed one
+ -- 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 :: Condition -> Condition -> Condition
+andCond c1 c2 tc = case c1 tc of
+ Nothing -> c2 tc -- c1 succeeds
+ Just x -> Just x -- c1 fails
+
+cond_std :: Condition
+cond_std (_, rep_tc)
+ | any (not . isVanillaDataCon) data_cons = Just existential_why
+ | null data_cons = Just no_cons_why
+ | otherwise = Nothing
+ where
+ data_cons = tyConDataCons rep_tc
+ no_cons_why = quotes (pprSourceTyCon rep_tc) <+>
+ ptext (sLit "has no data constructors")
+ existential_why = quotes (pprSourceTyCon rep_tc) <+>
+ ptext (sLit "has non-Haskell-98 constructor(s)")
+
+cond_isEnumeration :: Condition
+cond_isEnumeration (_, rep_tc)
+ | isEnumerationTyCon rep_tc = Nothing
+ | otherwise = Just why
+ where
+ why = quotes (pprSourceTyCon rep_tc) <+>
+ ptext (sLit "has non-nullary constructors")
+
+cond_isProduct :: Condition
+cond_isProduct (_, rep_tc)
+ | isProductTyCon rep_tc = Nothing
+ | otherwise = Just why
+ where
+ why = quotes (pprSourceTyCon rep_tc) <+>
+ 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 (_, rep_tc)
+ | tyConArity rep_tc > 7 = Just too_many
+ | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars rep_tc))
+ = Just bad_kind
+ | isFamInstTyCon rep_tc = Just fam_inst -- no Typable for family insts
+ | otherwise = Nothing
+ where
+ too_many = quotes (pprSourceTyCon rep_tc) <+>
+ ptext (sLit "has too many arguments")
+ bad_kind = quotes (pprSourceTyCon rep_tc) <+>
+ ptext (sLit "has arguments of kind other than `*'")
+ fam_inst = quotes (pprSourceTyCon rep_tc) <+>
+ ptext (sLit "is a type family")
+
+cond_mayDeriveDataTypeable :: Condition
+cond_mayDeriveDataTypeable (mayDeriveDataTypeable, _)
+ | mayDeriveDataTypeable = Nothing
+ | otherwise = Just why
+ where
+ why = ptext (sLit "You need -XDeriveDataTypeable 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]
+ -- Not Read/Show because they respect the type
+ -- Not Enum, because newtypes are never in Enum
+
+
+new_dfun_name :: Class -> TyCon -> TcM Name
+new_dfun_name clas tycon -- Just a simple wrapper
+ = do { loc <- getSrcSpanM -- The location of the instance decl, not of the tycon
+ ; newDFunName clas [mkTyConApp tycon []] loc }
+ -- The type passed to newDFunName is only used to generate
+ -- a suitable string; hence the empty type arg list
+\end{code}
+
+Note [Superclasses of derived instance]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general, a derived instance decl needs the superclasses of the derived
+class too. So if we have
+ data T a = ...deriving( Ord )
+then the initial context for Ord (T a) should include Eq (T a). Often this is
+redundant; we'll also generate an Ord constraint for each constructor argument,
+and that will probably generate enough constraints to make the Eq (T a) constraint
+be satisfied too. But not always; consider:
+
+ data S a = S
+ instance Eq (S a)
+ instance Ord (S a)
+
+ data T a = MkT (S a) deriving( Ord )
+ instance Num a => Eq (T a)
+
+The derived instance for (Ord (T a)) must have a (Num a) constraint!
+Similarly consider:
+ data T a = MkT deriving( Data, Typeable )
+Here there *is* no argument field, but we must nevertheless generate
+a context for the Data instances:
+ instance Typable a => Data (T a) where ...
+
+
+%************************************************************************
+%* *
+ Deriving newtypes
+%* *
+%************************************************************************
+
+\begin{code}
+mkNewTypeEqn :: InstOrigin -> Bool -> Bool -> [Var] -> Class
+ -> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
+ -> Maybe ThetaType
+ -> TcRn (Maybe EarlyDerivSpec)
+mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving tvs
+ cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
+ | can_derive_via_isomorphism && (newtype_deriving || std_class_via_iso cls)
+ = do { traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys)
+ ; dfun_name <- new_dfun_name cls tycon
+ ; loc <- getSrcSpanM
+ ; let spec = DS { ds_loc = loc, ds_orig = orig
+ , ds_name = dfun_name, ds_tvs = dict_tvs
+ , ds_cls = cls, ds_tys = inst_tys
+ , ds_theta = mtheta `orElse` all_preds
+ , ds_newtype = True }
+ ; return (if isJust mtheta then Just (Right spec)
+ else Just (Left spec)) }
+
+ | otherwise
+ = case check_conditions of
+ CanDerive -> mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
+ -- Use the standard H98 method
+ DerivableClassError msg -> bale_out msg -- Error with standard class
+ NonDerivableClass -- Must use newtype deriving
+ | newtype_deriving -> bale_out cant_derive_err -- Too hard, even with newtype deriving
+ | otherwise -> bale_out non_std_err -- Try newtype deriving!
+ where
+ check_conditions = checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tycon
+ bale_out msg = baleOut (derivingThingErr cls cls_tys tc_app msg)
+
+ non_std_err = nonStdErr cls $$
+ ptext (sLit "Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")