+ 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")
+
+ -- Here is the plan for newtype derivings. We see
+ -- newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)
+ -- where t is a type,
+ -- ak+1...an is a suffix of a1..an, and are all tyars
+ -- ak+1...an do not occur free in t, nor in the s1..sm
+ -- (C s1 ... sm) is a *partial applications* of class C
+ -- with the last parameter missing
+ -- (T a1 .. ak) matches the kind of C's last argument
+ -- (and hence so does t)
+ --
+ -- We generate the instance
+ -- instance forall ({a1..ak} u fvs(s1..sm)).
+ -- C s1 .. sm t => C s1 .. sm (T a1...ak)
+ -- where T a1...ap is the partial application of
+ -- the LHS of the correct kind and p >= k
+ --
+ -- NB: the variables below are:
+ -- tc_tvs = [a1, ..., an]
+ -- tyvars_to_keep = [a1, ..., ak]
+ -- rep_ty = t ak .. an
+ -- deriv_tvs = fvs(s1..sm) \ tc_tvs
+ -- tys = [s1, ..., sm]
+ -- rep_fn' = t
+ --
+ -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
+ -- We generate the instance
+ -- instance Monad (ST s) => Monad (T s) where
+
+ cls_tyvars = classTyVars cls
+ kind = tyVarKind (last cls_tyvars)
+ -- Kind of the thing we want to instance
+ -- e.g. argument kind of Monad, *->*
+
+ (arg_kinds, _) = splitKindFunTys 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)
+
+ -- Note [Newtype representation]
+ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ -- Need newTyConRhs (*not* a recursive representation finder)
+ -- to get the representation type. For example
+ -- newtype B = MkB Int
+ -- newtype A = MkA B deriving( Num )
+ -- We want the Num instance of B, *not* the Num instance of Int,
+ -- when making the Num instance of A!
+ rep_ty = newTyConInstRhs rep_tycon rep_tc_args
+ (rep_fn, rep_ty_args) = tcSplitAppTys rep_ty
+
+ n_tyargs_to_keep = tyConArity tycon - n_args_to_drop
+ dropped_tc_args = drop n_tyargs_to_keep tc_args
+ dropped_tvs = tyVarsOfTypes dropped_tc_args
+
+ n_args_to_keep = length rep_ty_args - 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
+
+ rep_fn' = mkAppTys rep_fn args_to_keep
+ rep_tys = cls_tys ++ [rep_fn']
+ rep_pred = mkClassPred cls rep_tys
+ -- rep_pred is the representation dictionary, from where
+ -- we are gong to get all the methods for the newtype
+ -- dictionary
+
+ tc_app = mkTyConApp tycon (take n_tyargs_to_keep tc_args)
+
+ -- Next we figure out what superclass dictionaries to use
+ -- See Note [Newtype deriving superclasses] above
+
+ inst_tys = cls_tys ++ [tc_app]
+ sc_theta = substTheta (zipOpenTvSubst cls_tyvars inst_tys)
+ (classSCTheta cls)
+
+ -- If there are no tyvars, there's no need
+ -- to abstract over the dictionaries we need
+ -- Example: newtype T = MkT Int deriving( C )
+ -- We get the derived instance
+ -- instance C T
+ -- rather than
+ -- instance C Int => C T
+ dict_tvs = filterOut (`elemVarSet` dropped_tvs) tvs
+ all_preds = rep_pred : sc_theta -- NB: rep_pred comes first
+
+ -------------------------------------------------------------------
+ -- Figuring out whether we can only do this newtype-deriving thing
+
+ right_arity = length cls_tys + 1 == classArity cls
+
+ -- Never derive Read,Show,Typeable,Data this way
+ non_iso_class cls = className cls `elem` ([readClassName, showClassName, dataClassName] ++
+ typeableClassNames)
+ can_derive_via_isomorphism
+ = not (non_iso_class cls)
+ && right_arity -- Well kinded;
+ -- eg not: newtype T ... deriving( ST )
+ -- because ST needs *2* type params
+ && n_tyargs_to_keep >= 0 -- Type constructor has right kind:
+ -- eg not: newtype T = T Int deriving( Monad )
+ && n_args_to_keep >= 0 -- Rep type has right kind:
+ -- 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 !!
+ -- Here's a recursive newtype that's actually OK
+ -- newtype S1 = S1 [T1 ()]
+ -- newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )
+ -- It's currently rejected. Oh well.
+ -- In fact we generate an instance decl that has method of form
+ -- meth @ instTy = meth @ repTy
+ -- (no coerce's). We'd need a coerce if we wanted to handle
+ -- recursive newtypes too
+
+ -- Check that eta reduction is OK
+ eta_ok = (args_to_drop `tcEqTypes` dropped_tc_args)
+ -- (a) the dropped-off args are identical in the source and rep type
+ -- newtype T a b = MkT (S [a] b) deriving( Monad )
+ -- Here the 'b' must be the same in the rep type (S [a] b)
+
+ && (tyVarsOfType rep_fn' `disjointVarSet` dropped_tvs)
+ -- (b) the remaining type args do not mention any of the dropped
+ -- type variables
+
+ && (tyVarsOfTypes cls_tys `disjointVarSet` dropped_tvs)
+ -- (c) the type class args do not mention any of the dropped type
+ -- variables
+
+ && all isTyVarTy dropped_tc_args
+ -- (d) in case of newtype family instances, the eta-dropped
+ -- arguments must be type variables (not more complex indexes)
+
+ cant_derive_err = vcat [ptext (sLit "even with cunning newtype deriving:"),
+ if isRecursiveTyCon tycon then
+ ptext (sLit "the newtype may be recursive")
+ else empty,
+ if not right_arity then
+ quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1")
+ else empty,
+ if not (n_tyargs_to_keep >= 0) then
+ ptext (sLit "the type constructor has wrong kind")
+ else if not (n_args_to_keep >= 0) then
+ ptext (sLit "the representation type has wrong kind")
+ else if not eta_ok then
+ ptext (sLit "the eta-reduction property does not hold")
+ else empty
+ ]