+ why = ptext (sLit "You need -X") <> text flag_str
+ <+> ptext (sLit "to derive an instance for this class")
+ flag_str = case [ s | (s, f, _) <- xFlags, f==flag ] of
+ [s] -> s
+ other -> pprPanic "checkFlag" (ppr other)
+
+std_class_via_iso :: Class -> Bool
+-- These standard classes can be derived for a newtype
+-- using the isomorphism trick *even if no -XGeneralizedNewtypeDeriving
+-- because giving so gives the same results as generating the boilerplate
+std_class_via_iso clas
+ = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
+ -- Not Read/Show because they respect the type
+ -- Not Enum, because newtypes are never in Enum
+
+
+non_iso_class :: Class -> Bool
+-- *Never* derive Read,Show,Typeable,Data by isomorphism,
+-- even with -XGeneralizedNewtypeDeriving
+non_iso_class cls
+ = classKey cls `elem` ([readClassKey, showClassKey, dataClassKey] ++
+ typeableClassKeys)
+
+typeableClassKeys :: [Unique]
+typeableClassKeys = map getUnique typeableClassNames
+
+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 :: CtOrigin -> DynFlags -> [Var] -> Class
+ -> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
+ -> DerivContext
+ -> 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 "newtype deriving:" (ppr tycon <+> ppr rep_tys <+> ppr all_preds)
+ ; 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 checkSideConditions dflags mtheta cls cls_tys rep_tycon of
+ CanDerive -> go_for_it -- Use the standard H98 method
+ DerivableClassError msg -- Error with standard class
+ | can_derive_via_isomorphism -> bale_out (msg $$ suggest_nd)
+ | otherwise -> bale_out msg
+ NonDerivableClass -- Must use newtype deriving
+ | newtype_deriving -> bale_out cant_derive_err -- Too hard, even with newtype deriving
+ | can_derive_via_isomorphism -> bale_out (non_std $$ suggest_nd) -- Try newtype deriving!
+ | otherwise -> bale_out non_std
+ where
+ newtype_deriving = xopt Opt_GeneralizedNewtypeDeriving dflags
+ go_for_it = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
+ bale_out msg = failWithTc (derivingThingErr newtype_deriving cls cls_tys inst_ty msg)
+
+ non_std = nonStdErr cls
+ suggest_nd = 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]
+
+ 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 [ ppUnless arity_ok arity_msg
+ , ppUnless eta_ok eta_msg
+ , ppUnless ats_ok 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")