+ tyvars = tyConTyVars tycon
+ data_cons = tyConDataCons tycon
+ constraints = extra_constraints ++
+ [ mkClassPred clas [arg_ty]
+ | data_con <- tyConDataCons tycon,
+ arg_ty <- dataConRepArgTys data_con,
+ -- Use the same type variables
+ -- as the type constructor,
+ -- hence no need to instantiate
+ not (isUnLiftedType arg_ty) -- No constraints for unlifted types?
+ ]
+
+
+ -- "extra_constraints": see notes above about contexts on data decls
+ extra_constraints | offensive_class = tyConTheta tycon
+ | otherwise = []
+
+ offensive_class = classKey clas `elem` needsDataDeclCtxtClassKeys
+
+
+ mk_eqn_help NewType tycon clas tys
+ = doptsTc Opt_GlasgowExts `thenTc` \ gla_exts ->
+ if can_derive_via_isomorphism && (gla_exts || standard_instance) then
+ -- Go ahead and use the isomorphism
+ new_dfun_name clas tycon `thenNF_Tc` \ dfun_name ->
+ returnTc (Nothing, Just (NewTypeDerived (mk_dfun dfun_name)))
+ else
+ if standard_instance then
+ mk_eqn_help DataType tycon clas [] -- Go via bale-out route
+ else
+ bale_out cant_derive_err
+ where
+ -- Here is the plan for newtype derivings. We see
+ -- newtype T a1...an = T (t ak...an) deriving (C1...Cm)
+ -- where aj...an do not occur free in t, and the Ci are *partial applications* of
+ -- classes with the last parameter missing
+ --
+ -- We generate the instances
+ -- instance Ci (t ak...aj) => Ci (T a1...aj)
+ -- where T a1...aj is the partial application of the LHS of the correct kind
+ --
+ -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
+
+ kind = tyVarKind (last (classTyVars clas))
+ -- Kind of the thing we want to instance
+ -- e.g. argument kind of Monad, *->*
+
+ (arg_kinds, _) = tcSplitFunTys kind
+ n_args_to_drop = length arg_kinds
+ -- Want to drop 1 arg from (T s a) and (ST s a)
+ -- to get instance Monad (ST s) => Monad (T s)
+
+ (tyvars, rep_ty) = newTyConRep tycon
+ maybe_rep_app = tcSplitTyConApp_maybe rep_ty
+ Just (rep_tc, rep_ty_args) = maybe_rep_app
+
+ n_tyvars_to_keep = tyConArity tycon - n_args_to_drop
+ tyvars_to_drop = drop n_tyvars_to_keep tyvars
+ tyvars_to_keep = take n_tyvars_to_keep tyvars
+
+ n_args_to_keep = tyConArity rep_tc - n_args_to_drop
+ args_to_drop = drop n_args_to_keep rep_ty_args
+ args_to_keep = take n_args_to_keep rep_ty_args
+
+ ctxt_pred = mkClassPred clas (tys ++ [mkTyConApp rep_tc args_to_keep])
+
+ mk_dfun dfun_name = mkDictFunId dfun_name clas tyvars
+ (tys ++ [mkTyConApp tycon (mkTyVarTys tyvars_to_keep)] )
+ [ctxt_pred]
+
+ -- We can only do this newtype deriving thing if:
+ standard_instance = null tys && classKey clas `elem` derivableClassKeys
+
+ can_derive_via_isomorphism
+ = not (clas `hasKey` readClassKey) -- Never derive Read,Show this way
+ && not (clas `hasKey` showClassKey)
+ && n_tyvars_to_keep >= 0 -- Well kinded;
+ -- eg not: newtype T = T Int deriving( Monad )
+ && isJust maybe_rep_app -- The rep type is a type constructor app
+ && n_args_to_keep >= 0 -- Well kinded:
+ -- eg not: newtype T a = T Int deriving( Monad )
+ && eta_ok -- Eta reduction works
+
+ -- Check that eta reduction is OK
+ -- (a) the dropped-off args are identical
+ -- (b) the remaining type args mention
+ -- only the remaining type variables
+ eta_ok = (args_to_drop `tcEqTypes` mkTyVarTys tyvars_to_drop)
+ && (tyVarsOfTypes args_to_keep `subVarSet` mkVarSet tyvars_to_keep)
+
+ cant_derive_err = derivingThingErr clas tys tycon tyvars_to_keep
+ SLIT("too hard for cunning newtype deriving")
+
+
+ bale_out err = addErrTc err `thenNF_Tc_` returnNF_Tc (Nothing, Nothing)
+
+ ------------------------------------------------------------------
+ chk_out :: Class -> TyCon -> [TcType] -> Maybe FastString
+ chk_out clas tycon tys
+ | not (null tys) = Just non_std_why
+ | not (getUnique clas `elem` derivableClassKeys) = Just non_std_why
+ | clas `hasKey` enumClassKey && not is_enumeration = Just nullary_why
+ | clas `hasKey` boundedClassKey && not is_enumeration_or_single = Just single_nullary_why
+ | clas `hasKey` ixClassKey && not is_enumeration_or_single = Just single_nullary_why
+ | null data_cons = Just no_cons_why
+ | any isExistentialDataCon data_cons = Just existential_why
+ | otherwise = Nothing
+ where
+ data_cons = tyConDataCons tycon
+ is_enumeration = isEnumerationTyCon tycon
+ is_single_con = maybeToBool (maybeTyConSingleCon tycon)
+ is_enumeration_or_single = is_enumeration || is_single_con
+
+ single_nullary_why = SLIT("one constructor data type or type with all nullary constructors expected")
+ nullary_why = SLIT("data type with all nullary constructors expected")
+ no_cons_why = SLIT("type has no data constructors")
+ non_std_why = SLIT("not a derivable class")
+ existential_why = SLIT("it has existentially-quantified constructor(s)")
+
+new_dfun_name clas tycon -- Just a simple wrapper
+ = newDFunName clas [mkTyConApp tycon []] (getSrcLoc tycon)
+ -- The type passed to newDFunName is only used to generate
+ -- a suitable string; hence the empty type arg list