+ ------------------------------------------------------------------
+ mk_eqn_help DataType tycon clas tys
+ | Just err <- chk_out clas tycon tys
+ = bale_out (derivingThingErr clas tys tycon tyvars err)
+ | otherwise
+ = new_dfun_name clas tycon `thenNF_Tc` \ dfun_name ->
+ returnNF_Tc (Just (dfun_name, clas, tycon, tyvars, constraints), Nothing)
+ where
+ 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 = tyConTheta tycon
+
+ -- | 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
+ && not (isRecursiveTyCon tycon) -- Does not work for recursive tycons:
+ -- newtype A = MkA [A]
+ -- Don't want
+ -- instance Eq [A] => Eq A !!
+
+ -- 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
+ (ptext SLIT("too hard for cunning newtype deriving"))
+
+ bale_out err = addErrTc err `thenNF_Tc_` returnNF_Tc (Nothing, Nothing)