Commit 4a03012a authored by Ryan Scott's avatar Ryan Scott

Refactor TcDeriv and TcGenDeriv

Summary:
Keeping a promise I made to Simon to clean up these modules.

This change splits up the massive `TcDeriv` and `TcGenDeriv` modules into
somewhat more manageable pieces. The new modules are:

* `TcGenFunctor`: This contains the deriving machinery for `Functor`,
  `Foldable`, and `Traversable` (which all use the same underlying algorithm).
* `TcDerivInfer`: This is the new home for `inferConstraints`,
  `simplifyInstanceContexts`, and related functions, whose role is to come up
  with the derived instance context and subsequently simplify it.
* `TcDerivUtils`: This is a grab-bag module that contains several
  error-checking utilities originally in `TcDeriv`, as well as some functions
  that `TcDeriv` and `TcDerivInfer` both need.

The end result is that `TcDeriv` is now less than 1,600 SLOC (originally 2,686
SLOC), and `TcGenDeriv` is now about 2,000 SLOC (originally 2,964).

In addition, this also implements a couple of tiny refactorings:

* I transformed `type Condition = (DynFlags, TyCon) -> Validity` into
  `type Condition = DynFlags -> TyCon -> Validity`
* I killed the `DerivSpecGeneric` constructor for `DerivSpecMechanism`, and
  merged its functionality into `DerivSpecStock`. In addition,
  `hasStockDeriving` now contains key-value pairs for `Generic` and `Generic1`,
  so they're no longer treated as an awkward special case in `TcDeriv`.

Test Plan: ./validate

Reviewers: simonpj, austin, bgamari

Reviewed By: simonpj

Subscribers: thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D2568
parent 58ecdf83
......@@ -405,10 +405,13 @@ Library
TcClassDcl
TcDefaults
TcDeriv
TcDerivInfer
TcDerivUtils
TcEnv
TcExpr
TcForeign
TcGenDeriv
TcGenFunctor
TcGenGenerics
TcHsSyn
TcHsType
......
......@@ -7,7 +7,6 @@ Handles @deriving@ clauses on @data@ declarations.
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ImplicitParams #-}
module TcDeriv ( tcDeriving, DerivInfo(..), mkDerivInfos ) where
......@@ -18,19 +17,17 @@ import DynFlags
import TcRnMonad
import FamInst
import TcErrors( reportAllUnsolved )
import TcValidity( validDerivPred, allDistinctTyVars )
import TcDerivInfer
import TcDerivUtils
import TcValidity( allDistinctTyVars )
import TcClassDcl( tcATDefault, tcMkDeclCtxt )
import TcEnv
import TcGenDeriv -- Deriv stuff
import TcGenGenerics
import InstEnv
import Inst
import FamInstEnv
import TcHsType
import TcMType
import TcSimplify
import TcUnify( buildImplicationFor )
import RnNames( extendGlobalRdrEnvRn )
import RnBinds
......@@ -54,7 +51,6 @@ import Var
import VarEnv
import VarSet
import PrelNames
import THNames ( liftClassKey )
import SrcLoc
import Util
import Outputable
......@@ -84,81 +80,6 @@ Overall plan
3. Add the derived bindings, generating InstInfos
-}
-- DerivSpec is purely local to this module
data DerivSpec theta = DS { ds_loc :: SrcSpan
, ds_name :: Name -- DFun name
, ds_tvs :: [TyVar]
, ds_theta :: theta
, ds_cls :: Class
, ds_tys :: [Type]
, ds_tc :: TyCon
, ds_overlap :: Maybe OverlapMode
, ds_mechanism :: DerivSpecMechanism }
-- This spec implies a dfun declaration of the form
-- df :: forall tvs. theta => C tys
-- The Name is the name for the DFun we'll build
-- The tyvars bind all the variables in the theta
-- For type families, the tycon in
-- in ds_tys is the *family* tycon
-- in ds_tc is the *representation* type
-- For non-family tycons, both are the same
-- the theta is either the given and final theta, in standalone deriving,
-- or the not-yet-simplified list of constraints together with their origin
-- ds_mechanism specifies the means by which GHC derives the instance.
-- See Note [Deriving strategies]
{-
Example:
newtype instance T [a] = MkT (Tree a) deriving( C s )
==>
axiom T [a] = :RTList a
axiom :RTList a = Tree a
DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]]
, ds_tc = :RTList, ds_mechanism = DerivSpecNewtype (Tree a) }
-}
-- What action to take in order to derive a class instance.
-- See Note [Deriving strategies]
-- NB: DerivSpecMechanism is purely local to this module
data DerivSpecMechanism
= DerivSpecStock -- "Standard" classes (except for Generic(1), which is
-- covered by the special case of DerivSpecGeneric)
(SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff))
| DerivSpecGeneric -- -XDeriveGeneric
(TyCon -> [Type] -> TcM (LHsBinds RdrName, FamInst))
| DerivSpecNewtype -- -XGeneralizedNewtypeDeriving
Type -- ^ The newtype rep type
| DerivSpecAnyClass -- -XDeriveAnyClass
type DerivContext = Maybe ThetaType
-- Nothing <=> Vanilla deriving; infer the context of the instance decl
-- Just theta <=> Standalone deriving: context supplied by programmer
-- | A 'PredType' annotated with the origin of the constraint 'CtOrigin',
-- and whether or the constraint deals in types or kinds.
data PredOrigin = PredOrigin PredType CtOrigin TypeOrKind
type ThetaOrigin = [PredOrigin]
mkPredOrigin :: CtOrigin -> TypeOrKind -> PredType -> PredOrigin
mkPredOrigin origin t_or_k pred = PredOrigin pred origin t_or_k
mkThetaOrigin :: CtOrigin -> TypeOrKind -> ThetaType -> ThetaOrigin
mkThetaOrigin origin t_or_k = map (mkPredOrigin origin t_or_k)
substPredOrigin :: HasCallStack => TCvSubst -> PredOrigin -> PredOrigin
substPredOrigin subst (PredOrigin pred origin t_or_k)
= PredOrigin (substTy subst pred) origin t_or_k
substThetaOrigin :: HasCallStack => TCvSubst -> ThetaOrigin -> ThetaOrigin
substThetaOrigin subst = map (substPredOrigin subst)
data EarlyDerivSpec = InferTheta (DerivSpec ThetaOrigin)
| GivenTheta (DerivSpec ThetaType)
-- InferTheta ds => the context for the instance should be inferred
......@@ -170,7 +91,7 @@ data EarlyDerivSpec = InferTheta (DerivSpec ThetaOrigin)
--
-- GivenTheta ds => the exact context for the instance is supplied
-- by the programmer; it is ds_theta
-- See Note [Inferring the instance context]
-- See Note [Inferring the instance context] in TcDerivInfer
earlyDSLoc :: EarlyDerivSpec -> SrcSpan
earlyDSLoc (InferTheta spec) = ds_loc spec
......@@ -183,83 +104,11 @@ splitEarlyDerivSpec (InferTheta spec : specs) =
splitEarlyDerivSpec (GivenTheta spec : specs) =
case splitEarlyDerivSpec specs of (is, gs) -> (is, spec : gs)
pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc
pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs,
ds_cls = c, ds_tys = tys, ds_theta = rhs })
= hang (text "DerivSpec")
2 (vcat [ text "ds_loc =" <+> ppr l
, text "ds_name =" <+> ppr n
, text "ds_tvs =" <+> ppr tvs
, text "ds_cls =" <+> ppr c
, text "ds_tys =" <+> ppr tys
, text "ds_theta =" <+> ppr rhs ])
instance Outputable theta => Outputable (DerivSpec theta) where
ppr = pprDerivSpec
instance Outputable EarlyDerivSpec where
ppr (InferTheta spec) = ppr spec <+> text "(Infer)"
ppr (GivenTheta spec) = ppr spec <+> text "(Given)"
instance Outputable PredOrigin where
ppr (PredOrigin ty _ _) = ppr ty -- The origin is not so interesting when debugging
{- Note [Inferring the instance context]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There are two sorts of 'deriving':
* InferTheta: the deriving clause for a data type
data T a = T1 a deriving( Eq )
Here we must infer an instance context,
and generate instance declaration
instance Eq a => Eq (T a) where ...
* CheckTheta: standalone deriving
deriving instance Eq a => Eq (T a)
Here we only need to fill in the bindings;
the instance context is user-supplied
For a deriving clause (InferTheta) we must figure out the
instance context (inferConstraints). Suppose we are inferring
the instance context for
C t1 .. tn (T s1 .. sm)
There are two cases
* (T s1 .. sm) :: * (the normal case)
Then we behave like Eq and guess (C t1 .. tn t)
for each data constructor arg of type t. More
details below.
* (T s1 .. sm) :: * -> * (the functor-like case)
Then we behave like Functor.
In both cases we produce a bunch of un-simplified constraints
and them simplify them in simplifyInstanceContexts; see
Note [Simplifying the instance context].
In the functor-like case, we may need to unify some kind variables with * in
order for the generated instance to be well-kinded. An example from
Trac #10524:
newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1)
= Compose (f (g a)) deriving Functor
Earlier in the deriving pipeline, GHC unifies the kind of Compose f g
(k1 -> *) with the kind of Functor's argument (* -> *), so k1 := *. But this
alone isn't enough, since k2 wasn't unified with *:
instance (Functor (f :: k2 -> *), Functor (g :: * -> k2)) =>
Functor (Compose f g) where ...
The two Functor constraints are ill-kinded. To ensure this doesn't happen, we:
1. Collect all of a datatype's subtypes which require functor-like
constraints.
2. For each subtype, create a substitution by unifying the subtype's kind
with (* -> *).
3. Compose all the substitutions into one, then apply that substitution to
all of the in-scope type variables and the instance types.
{-
Note [Data decl contexts]
~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
......@@ -1088,12 +937,7 @@ mk_eqn_stock dflags mtheta cls cls_tys rep_tc go_for_it bale_out
mk_eqn_stock' :: Class -> (DerivSpecMechanism -> TcRn EarlyDerivSpec)
-> TcRn EarlyDerivSpec
mk_eqn_stock' cls go_for_it
| let ck = classKey cls
, ck `elem` [genClassKey, gen1ClassKey]
= let gk = if ck == genClassKey then Gen0 else Gen1
in go_for_it . DerivSpecGeneric . gen_Generic_binds $ gk
| otherwise = go_for_it $ case hasStockDeriving cls of
= go_for_it $ case hasStockDeriving cls of
Just gen_fn -> DerivSpecStock gen_fn
Nothing ->
pprPanic "mk_eqn_stock': Not a stock class!" (ppr cls)
......@@ -1119,620 +963,7 @@ mk_eqn_no_mechanism dflags mtheta cls cls_tys rep_tc go_for_it bale_out
CanDerive -> mk_eqn_stock' cls go_for_it
DerivableViaInstance -> go_for_it DerivSpecAnyClass
----------------------
inferConstraints :: [TyVar] -> Class -> [TcType] -> TcType
-> TyCon -> [TcType]
-> (ThetaOrigin -> [TyVar] -> [TcType] -> TcM a)
-> TcM a
-- inferConstraints figures out the constraints needed for the
-- instance declaration generated by a 'deriving' clause on a
-- data type declaration. It also returns the new in-scope type
-- variables and instance types, in case they were changed due to
-- the presence of functor-like constraints.
-- See Note [Inferring the instance context]
-- e.g. inferConstraints
-- C Int (T [a]) -- Class and inst_tys
-- :RTList a -- Rep tycon and its arg tys
-- where T [a] ~R :RTList a
--
-- Generate a sufficiently large set of constraints that typechecking the
-- generated method definitions should succeed. This set will be simplified
-- before being used in the instance declaration
inferConstraints tvs main_cls cls_tys inst_ty rep_tc rep_tc_args mkTheta
| is_generic -- Generic constraints are easy
= mkTheta [] tvs inst_tys
| is_generic1 -- Generic1 needs Functor
= ASSERT( length rep_tc_tvs > 0 ) -- See Note [Getting base classes]
ASSERT( length cls_tys == 1 ) -- Generic1 has a single kind variable
do { functorClass <- tcLookupClass functorClassName
; con_arg_constraints (get_gen1_constraints functorClass) mkTheta }
| otherwise -- The others are a bit more complicated
= ASSERT2( equalLength rep_tc_tvs all_rep_tc_args
, ppr main_cls <+> ppr rep_tc
$$ ppr rep_tc_tvs $$ ppr all_rep_tc_args )
con_arg_constraints get_std_constrained_tys
$ \arg_constraints tvs' inst_tys' ->
do { traceTc "inferConstraints" $ vcat
[ ppr main_cls <+> ppr inst_tys'
, ppr arg_constraints
]
; mkTheta (stupid_constraints ++ extra_constraints
++ sc_constraints ++ arg_constraints)
tvs' inst_tys' }
where
tc_binders = tyConBinders rep_tc
choose_level bndr
| isNamedTyConBinder bndr = KindLevel
| otherwise = TypeLevel
t_or_ks = map choose_level tc_binders ++ repeat TypeLevel
-- want to report *kind* errors when possible
-- Constraints arising from the arguments of each constructor
con_arg_constraints :: (CtOrigin -> TypeOrKind
-> Type
-> [(ThetaOrigin, Maybe TCvSubst)])
-> (ThetaOrigin -> [TyVar] -> [TcType] -> TcM a)
-> TcM a
con_arg_constraints get_arg_constraints mkTheta
= let (predss, mbSubsts) = unzip
[ preds_and_mbSubst
| data_con <- tyConDataCons rep_tc
, (arg_n, arg_t_or_k, arg_ty)
<- zip3 [1..] t_or_ks $
dataConInstOrigArgTys data_con all_rep_tc_args
-- No constraints for unlifted types
-- See Note [Deriving and unboxed types]
, not (isUnliftedType arg_ty)
, let orig = DerivOriginDC data_con arg_n
, preds_and_mbSubst <- get_arg_constraints orig arg_t_or_k arg_ty
]
preds = concat predss
-- If the constraints require a subtype to be of kind (* -> *)
-- (which is the case for functor-like constraints), then we
-- explicitly unify the subtype's kinds with (* -> *).
-- See Note [Inferring the instance context]
subst = foldl' composeTCvSubst
emptyTCvSubst (catMaybes mbSubsts)
unmapped_tvs = filter (\v -> v `notElemTCvSubst` subst
&& not (v `isInScope` subst)) tvs
(subst', _) = mapAccumL substTyVarBndr subst unmapped_tvs
preds' = substThetaOrigin subst' preds
inst_tys' = substTys subst' inst_tys
tvs' = tyCoVarsOfTypesWellScoped inst_tys'
in mkTheta preds' tvs' inst_tys'
is_generic = main_cls `hasKey` genClassKey
is_generic1 = main_cls `hasKey` gen1ClassKey
-- is_functor_like: see Note [Inferring the instance context]
is_functor_like = typeKind inst_ty `tcEqKind` typeToTypeKind
|| is_generic1 -- Technically, Generic1 requires a type of
-- kind (k -> *), not (* -> *), but we still
-- label it "functor-like" to make sure
-- all_rep_tc_args has all the necessary type
-- variables it needs to function.
get_gen1_constraints :: Class -> CtOrigin -> TypeOrKind -> Type
-> [(ThetaOrigin, Maybe TCvSubst)]
get_gen1_constraints functor_cls orig t_or_k ty
= mk_functor_like_constraints orig t_or_k functor_cls $
get_gen1_constrained_tys last_tv ty
get_std_constrained_tys :: CtOrigin -> TypeOrKind -> Type
-> [(ThetaOrigin, Maybe TCvSubst)]
get_std_constrained_tys orig t_or_k ty
| is_functor_like = mk_functor_like_constraints orig t_or_k main_cls $
deepSubtypesContaining last_tv ty
| otherwise = [( [mk_cls_pred orig t_or_k main_cls ty]
, Nothing )]
mk_functor_like_constraints :: CtOrigin -> TypeOrKind
-> Class -> [Type]
-> [(ThetaOrigin, Maybe TCvSubst)]
-- 'cls' is usually main_cls (Functor or Traversable etc), but if
-- main_cls = Generic1, then 'cls' can be Functor; see get_gen1_constraints
--
-- For each type, generate two constraints, [cls ty, kind(ty) ~ (*->*)],
-- and a kind substitution that results from unifying kind(ty) with * -> *.
-- If the unification is successful, it will ensure that the resulting
-- instance is well kinded. If not, the second constraint will result
-- in an error message which points out the kind mismatch.
-- See Note [Inferring the instance context]
mk_functor_like_constraints orig t_or_k cls
= map $ \ty -> let ki = typeKind ty in
( [ mk_cls_pred orig t_or_k cls ty
, mkPredOrigin orig KindLevel
(mkPrimEqPred ki typeToTypeKind) ]
, tcUnifyTy ki typeToTypeKind
)
rep_tc_tvs = tyConTyVars rep_tc
last_tv = last rep_tc_tvs
all_rep_tc_args | is_functor_like = rep_tc_args ++ [mkTyVarTy last_tv]
| otherwise = rep_tc_args
-- Constraints arising from superclasses
-- See Note [Superclasses of derived instance]
cls_tvs = classTyVars main_cls
inst_tys = cls_tys ++ [inst_ty]
sc_constraints = ASSERT2( equalLength cls_tvs inst_tys, ppr main_cls <+> ppr rep_tc)
mkThetaOrigin DerivOrigin TypeLevel $
substTheta cls_subst (classSCTheta main_cls)
cls_subst = ASSERT( equalLength cls_tvs inst_tys )
zipTvSubst cls_tvs inst_tys
-- Stupid constraints
stupid_constraints = mkThetaOrigin DerivOrigin TypeLevel $
substTheta tc_subst (tyConStupidTheta rep_tc)
tc_subst = ASSERT( equalLength rep_tc_tvs all_rep_tc_args )
zipTvSubst rep_tc_tvs all_rep_tc_args
-- Extra Data constraints
-- The Data class (only) requires that for
-- instance (...) => Data (T t1 t2)
-- IF t1:*, t2:*
-- THEN (Data t1, Data t2) are among the (...) constraints
-- Reason: when the IF holds, we generate a method
-- dataCast2 f = gcast2 f
-- and we need the Data constraints to typecheck the method
extra_constraints
| main_cls `hasKey` dataClassKey
, all (isLiftedTypeKind . typeKind) rep_tc_args
= [ mk_cls_pred DerivOrigin t_or_k main_cls ty
| (t_or_k, ty) <- zip t_or_ks rep_tc_args]
| otherwise
= []
mk_cls_pred orig t_or_k cls ty -- Don't forget to apply to cls_tys' too
= mkPredOrigin orig t_or_k (mkClassPred cls (cls_tys' ++ [ty]))
cls_tys' | is_generic1 = [] -- In the awkward Generic1 case, cls_tys'
-- should be empty, since we are applying the
-- class Functor.
| otherwise = cls_tys
{- Note [Getting base classes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Functor and Typeable are defined in package 'base', and that is not available
when compiling 'ghc-prim'. So we must be careful that 'deriving' for stuff in
ghc-prim does not use Functor or Typeable implicitly via these lookups.
Note [Deriving and unboxed types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We have some special hacks to support things like
data T = MkT Int# deriving ( Show )
Specifically, we use TcGenDeriv.box to box the Int# into an Int
(which we know how to show), and append a '#'. Parenthesis are not required
for unboxed values (`MkT -3#` is a valid expression).
Note [Deriving any class]
~~~~~~~~~~~~~~~~~~~~~~~~~
Classic uses of a deriving clause, or a standalone-deriving declaration, are
for:
* a stock class like Eq or Show, for which GHC knows how to generate
the instance code
* a newtype, via the mechanism enabled by GeneralizedNewtypeDeriving
The DeriveAnyClass extension adds a third way to derive instances, based on
empty instance declarations.
The canonical use case is in combination with GHC.Generics and default method
signatures. These allow us to have instance declarations being empty, but still
useful, e.g.
data T a = ...blah..blah... deriving( Generic )
instance C a => C (T a) -- No 'where' clause
where C is some "random" user-defined class.
This boilerplate code can be replaced by the more compact
data T a = ...blah..blah... deriving( Generic, C )
if DeriveAnyClass is enabled.
This is not restricted to Generics; any class can be derived, simply giving
rise to an empty instance.
Unfortunately, it is not clear how to determine the context (when using a
deriving clause; in standalone deriving, the user provides the context).
GHC uses the same heuristic for figuring out the class context that it uses for
Eq in the case of *-kinded classes, and for Functor in the case of
* -> *-kinded classes. That may not be optimal or even wrong. But in such
cases, standalone deriving can still be used.
-}
------------------------------------------------------------------
-- Check side conditions that dis-allow derivability for particular classes
-- This is *apart* from the newtype-deriving mechanism
--
-- Here we get the representation tycon in case of family instances as it has
-- the data constructors - but we need to be careful to fall back to the
-- family tycon (with indexes) in error messages.
data DerivStatus = CanDerive -- Stock class, can derive
| DerivableClassError SDoc -- Stock class, but can't do it
| DerivableViaInstance -- See Note [Deriving any class]
| NonDerivableClass SDoc -- Non-stock class
-- A stock class is one either defined in the Haskell report or for which GHC
-- otherwise knows how to generate code for (possibly requiring the use of a
-- language extension), such as Eq, Ord, Ix, Data, Generic, etc.
checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType]
-> TyCon -- tycon
-> DerivStatus
checkSideConditions dflags mtheta cls cls_tys rep_tc
| Just cond <- sideConditions mtheta cls
= case (cond (dflags, rep_tc)) of
NotValid err -> DerivableClassError err -- Class-specific error
IsValid | null (filterOutInvisibleTypes (classTyCon cls) cls_tys)
-> CanDerive
-- All stock derivable classes are unary in the sense that
-- there should be not types in cls_tys (i.e., no type args
-- other than last). Note that cls_types can contain
-- invisible types as well (e.g., for Generic1, which is
-- poly-kinded), so make sure those are not counted.
| otherwise -> DerivableClassError (classArgsErr cls cls_tys)
-- e.g. deriving( Eq s )
| Just err <- canDeriveAnyClass dflags rep_tc cls
= NonDerivableClass err -- DeriveAnyClass does not work
| otherwise
= DerivableViaInstance -- DeriveAnyClass should work
classArgsErr :: Class -> [Type] -> SDoc
classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is not a class"
nonUnaryErr :: LHsSigType Name -> SDoc
nonUnaryErr ct = quotes (ppr ct)
<+> text "is not a unary constraint, as expected by a deriving clause"
nonStdErr :: Class -> SDoc
nonStdErr cls =
quotes (ppr cls)
<+> text "is not a stock derivable class (Eq, Show, etc.)"
gndNonNewtypeErr :: SDoc
gndNonNewtypeErr =
text "GeneralizedNewtypeDeriving cannot be used on non-newtypes"
-- Side conditions (whether the datatype must have at least one constructor,
-- required language extensions, etc.) for using GHC's stock deriving
-- mechanism on certain classes (as opposed to classes that require
-- GeneralizedNewtypeDeriving or DeriveAnyClass). Returns Nothing for a
-- class for which stock deriving isn't possible.
--
-- NB: The classes listed below should be in sync with the ones listed in the
-- definition of hasStockDeriving in TcGenDeriv (except for Generic(1),
-- which are handled specially). If you add new class to sideConditions,
-- make sure to update hasStockDeriving as well!
sideConditions :: DerivContext -> Class -> Maybe Condition
sideConditions mtheta cls
| cls_key == eqClassKey = Just (cond_std `andCond` cond_args cls)
| cls_key == ordClassKey = Just (cond_std `andCond` cond_args cls)
| cls_key == showClassKey = Just (cond_std `andCond` cond_args cls)
| cls_key == readClassKey = Just (cond_std `andCond` cond_args cls)
| cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration)
| cls_key == ixClassKey = Just (cond_std `andCond` cond_enumOrProduct cls)
| cls_key == boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct cls)
| cls_key == dataClassKey = Just (checkFlag LangExt.DeriveDataTypeable `andCond`
cond_std `andCond`
cond_args cls)
| cls_key == functorClassKey = Just (checkFlag LangExt.DeriveFunctor `andCond`
cond_vanilla `andCond`
cond_functorOK True False)
| cls_key == foldableClassKey = Just (checkFlag LangExt.DeriveFoldable `andCond`
cond_vanilla `andCond`
cond_functorOK False True)
-- Functor/Fold/Trav works ok
-- for rank-n types
| cls_key == traversableClassKey = Just (checkFlag LangExt.DeriveTraversable `andCond`
cond_vanilla `andCond`
cond_functorOK False False)
| cls_key == genClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond`
cond_vanilla `andCond`
cond_RepresentableOk)
| cls_key == gen1ClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond`
cond_vanilla `andCond`
cond_Representable1Ok)
| cls_key == liftClassKey = Just (checkFlag LangExt.DeriveLift `andCond`
cond_vanilla `andCond`
cond_args cls)
| otherwise = Nothing
where
cls_key = getUnique cls
cond_std = cond_stdOK mtheta False -- Vanilla data constructors, at least one,
-- and monotype arguments
cond_vanilla = cond_stdOK mtheta True -- Vanilla data constructors but
-- allow no data cons or polytype arguments
canDeriveAnyClass :: DynFlags -> TyCon -> Class -> Maybe SDoc
-- Nothing: we can (try to) derive it via an empty instance declaration
-- Just s: we can't, reason s
-- Precondition: the class is not one of the standard ones
canDeriveAnyClass dflags _tycon clas
| not (xopt LangExt.DeriveAnyClass dflags)
= Just (text "Try enabling DeriveAnyClass")
| not (any (target_kind `tcEqKind`) [ liftedTypeKind, typeToTypeKind ])
= Just (text "The last argument of class" <+> quotes (ppr clas)
<+> text "does not have kind * or (* -> *)")
| otherwise
= Nothing -- OK!
where
-- We are making an instance (C t1 .. tn (T s1 .. sm))
-- and we can only do so if the kind of C's last argument
-- is * or (* -> *). Because only then can we make a reasonable
-- guess at the instance context
target_kind = tyVarKind (last (classTyVars clas))
typeToTypeKind :: Kind
typeToTypeKind = liftedTypeKind `mkFunTy` liftedTypeKind
type Condition = (DynFlags, TyCon) -> Validity
-- TyCon is the *representation* tycon if the data type is an indexed one
-- Nothing => OK
orCond :: Condition -> Condition -> Condition
orCond c1 c2 tc
= case (c1 tc, c2 tc) of
(IsValid, _) -> IsValid -- c1 succeeds
(_, IsValid) -> IsValid -- c21 succeeds
(NotValid x, NotValid y) -> NotValid (x $$ text " or" $$ y)
-- Both fail
andCond :: Condition -> Condition -> Condition