+ data_cons = tyConDataCons rep_tc
+ check_con con = msum (check_vanilla con : foldDataConArgs (ft_check con) con)
+
+ check_vanilla :: DataCon -> Maybe SDoc
+ check_vanilla con | isVanillaDataCon con = Nothing
+ | otherwise = Just (badCon con existential)
+
+ ft_check :: DataCon -> FFoldType (Maybe SDoc)
+ ft_check con = FT { ft_triv = Nothing, ft_var = Nothing
+ , ft_co_var = Just (badCon con covariant)
+ , ft_fun = \x y -> if allowFunctions then x `mplus` y
+ else Just (badCon con functions)
+ , ft_tup = \_ xs -> msum xs
+ , ft_ty_app = \_ x -> x
+ , ft_bad_app = Just (badCon con wrong_arg)
+ , ft_forall = \_ x -> x }
+
+ existential = ptext (sLit "has existential arguments")
+ covariant = ptext (sLit "uses the type variable in a function argument")
+ functions = ptext (sLit "contains function types")
+ wrong_arg = ptext (sLit "uses the type variable in an argument other than the last")
+
+cond_mayDeriveDataTypeable :: Condition
+cond_mayDeriveDataTypeable (dflags, _)
+ | dopt Opt_DeriveDataTypeable dflags = 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
+
+badCon :: DataCon -> SDoc -> SDoc
+badCon con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg
+\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 -> DynFlags -> [Var] -> Class
+ -> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
+ -> Maybe ThetaType
+ -> TcRn EarlyDerivSpec
+mkNewTypeEqn orig dflags tvs
+ cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
+-- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
+ | 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 = varSetElems dfun_tvs
+ , ds_cls = cls, ds_tys = inst_tys
+ , ds_tc = rep_tycon, ds_tc_args = rep_tc_args
+ , ds_theta = mtheta `orElse` all_preds
+ , ds_newtype = True }
+ ; return (if isJust mtheta then Right spec
+ else 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
+ newtype_deriving = dopt Opt_GeneralizedNewtypeDeriving dflags
+ check_conditions = checkSideConditions dflags cls cls_tys rep_tycon
+ bale_out msg = failWithTc (derivingThingErr cls cls_tys inst_ty 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)
+ -- The latter kind-check has been done by deriveTyData already,
+ -- and tc_args are already trimmed
+ --
+ -- 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
+
+ nt_eta_arity = length (fst (newTyConEtadRhs rep_tycon))
+ -- For newtype T a b = MkT (S a a b), the TyCon machinery already
+ -- eta-reduces the representation type, so we know that
+ -- T a ~ S a a
+ -- That's convenient here, because we may have to apply
+ -- it to fewer than its original complement of arguments
+
+ -- 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_inst_ty = newTyConInstRhs rep_tycon rep_tc_args
+ rep_tys = cls_tys ++ [rep_inst_ty]
+ 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
+
+
+ -- Next we figure out what superclass dictionaries to use
+ -- See Note [Newtype deriving superclasses] above
+
+ cls_tyvars = classTyVars cls
+ dfun_tvs = tyVarsOfTypes inst_tys
+ inst_ty = mkTyConApp tycon tc_args
+ inst_tys = cls_tys ++ [inst_ty]
+ 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
+ all_preds = rep_pred : sc_theta -- NB: rep_pred comes first
+
+ -------------------------------------------------------------------
+ -- Figuring out whether we can only do this newtype-deriving thing
+
+ can_derive_via_isomorphism
+ = not (non_iso_class cls)
+ && arity_ok
+ && eta_ok
+ && ats_ok
+-- && not (isRecursiveTyCon tycon) -- Note [Recursive newtypes]
+
+ -- Never derive Read,Show,Typeable,Data by isomorphism
+ non_iso_class cls = className cls `elem` ([readClassName, showClassName, dataClassName] ++
+ typeableClassNames)
+
+ arity_ok = length cls_tys + 1 == classArity cls
+ -- Well kinded; eg not: newtype T ... deriving( ST )
+ -- because ST needs *2* type params
+
+ -- Check that eta reduction is OK
+ eta_ok = nt_eta_arity <= length rep_tc_args
+ -- The newtype can be eta-reduced to match the number
+ -- of type argument actually supplied
+ -- newtype T a b = MkT (S [a] b) deriving( Monad )
+ -- Here the 'b' must be the same in the rep type (S [a] b)
+ -- And the [a] must not mention 'b'. That's all handled
+ -- by nt_eta_rity.
+
+ ats_ok = null (classATs cls)
+ -- No associated types for the class, because we don't
+ -- currently generate type 'instance' decls; and cannot do
+ -- so for 'data' instance decls
+
+ cant_derive_err
+ = vcat [ ptext (sLit "even with cunning newtype deriving:")
+ , if arity_ok then empty else arity_msg
+ , if eta_ok then empty else eta_msg
+ , if ats_ok then empty else ats_msg ]
+ arity_msg = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1")
+ eta_msg = ptext (sLit "cannot eta-reduce the representation type enough")
+ ats_msg = ptext (sLit "the class has associated types")