import Outputable
import FastString
import Bag
+
+import Control.Monad
\end{code}
%************************************************************************
className cls `elem` typeableClassNames)
(derivingHiddenErr tycon)
- ; mayDeriveDataTypeable <- doptM Opt_DeriveDataTypeable
- ; newtype_deriving <- doptM Opt_GeneralizedNewtypeDeriving
-
+ ; dflags <- getDOpts
; if isDataTyCon rep_tc then
- mkDataTypeEqn orig mayDeriveDataTypeable tvs cls cls_tys
+ mkDataTypeEqn orig dflags tvs cls cls_tys
tycon tc_args rep_tc rep_tc_args mtheta
else
- mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving
- tvs cls cls_tys
+ mkNewTypeEqn orig dflags tvs cls cls_tys
tycon tc_args rep_tc rep_tc_args mtheta }
| otherwise
= failWithTc (derivingThingErr cls cls_tys tc_app
%************************************************************************
\begin{code}
-mkDataTypeEqn :: InstOrigin -> Bool -> [Var] -> Class -> [Type]
- -> TyCon -> [Type] -> TyCon -> [Type] -> Maybe ThetaType
- -> TcRn EarlyDerivSpec -- Return 'Nothing' if error
-
-mkDataTypeEqn orig mayDeriveDataTypeable tvs cls cls_tys
+mkDataTypeEqn :: InstOrigin
+ -> DynFlags
+ -> [Var] -- Universally quantified type variables in the instance
+ -> Class -- Class for which we need to derive an instance
+ -> [Type] -- Other parameters to the class except the last
+ -> TyCon -- Type constructor for which the instance is requested (last parameter to the type class)
+ -> [Type] -- Parameters to the type constructor
+ -> TyCon -- rep of the above (for type families)
+ -> [Type] -- rep of the above
+ -> Maybe ThetaType -- Context of the instance, for standalone deriving
+ -> TcRn EarlyDerivSpec -- Return 'Nothing' if error
+
+mkDataTypeEqn orig dflags tvs cls cls_tys
tycon tc_args rep_tc rep_tc_args mtheta
- = case checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc of
+ = case checkSideConditions dflags cls cls_tys rep_tc of
-- NB: pass the *representation* tycon to checkSideConditions
CanDerive -> mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
NonDerivableClass -> bale_out (nonStdErr cls)
= [ mkClassPred cls [arg_ty]
| data_con <- tyConDataCons rep_tc,
arg_ty <- ASSERT( isVanillaDataCon data_con )
- dataConInstOrigArgTys data_con rep_tc_args,
+ get_constrained_tys $
+ substTys subst $
+ dataConInstOrigArgTys data_con all_rep_tc_args,
not (isUnLiftedType arg_ty) ]
-- No constraints for unlifted types
-- Where they are legal we generate specilised function calls
+ -- For functor-like classes, two things are different
+ -- (a) We recurse over argument types to generate constraints
+ -- See Functor examples in TcGenDeriv
+ -- (b) The rep_tc_args will be one short
+ is_functor_like = getUnique cls `elem` functorLikeClassKeys
+
+ get_constrained_tys :: [Type] -> [Type]
+ get_constrained_tys tys
+ | is_functor_like = concatMap (deepSubtypesContaining last_tv) tys
+ | otherwise = tys
+
+ 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
+
+
-- See Note [Superclasses of derived instance]
sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys)
(classSCTheta cls)
inst_tys = [mkTyConApp tycon tc_args]
+ subst = zipTopTvSubst rep_tc_tvs all_rep_tc_args
+ stupid_constraints = substTheta subst (tyConStupidTheta rep_tc)
- stupid_subst = zipTopTvSubst (tyConTyVars rep_tc) rep_tc_args
- stupid_constraints = substTheta stupid_subst (tyConStupidTheta rep_tc)
all_constraints = stupid_constraints ++ sc_constraints ++ ordinary_constraints
spec = DS { ds_loc = loc, ds_orig = orig
, ds_theta = mtheta `orElse` all_constraints
, ds_newtype = False }
- ; return (if isJust mtheta then Right spec -- Specified context
+ ; ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr tycon )
+ return (if isJust mtheta then Right spec -- Specified context
else Left spec) } -- Infer context
mk_typeable_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
, ds_tc = rep_tc, ds_tc_args = rep_tc_args
, ds_theta = mtheta `orElse` [], ds_newtype = False }) }
+
------------------------------------------------------------------
-- Check side conditions that dis-allow derivability for particular classes
-- This is *apart* from the newtype-deriving mechanism
| DerivableClassError SDoc -- Standard class, but can't do it
| NonDerivableClass -- Non-standard class
-checkSideConditions :: Bool -> Class -> [TcType] -> TyCon -> DerivStatus
-checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc
+checkSideConditions :: DynFlags -> Class -> [TcType] -> TyCon -> DerivStatus
+checkSideConditions dflags cls cls_tys rep_tc
| Just cond <- sideConditions cls
- = case (cond (mayDeriveDataTypeable, rep_tc)) of
+ = case (cond (dflags, rep_tc)) of
Just err -> DerivableClassError err -- Class-specific error
Nothing | null cls_tys -> CanDerive
| otherwise -> DerivableClassError ty_args_why -- e.g. deriving( Eq s )
sideConditions :: Class -> Maybe Condition
sideConditions cls
- | cls_key == eqClassKey = Just cond_std
- | cls_key == ordClassKey = Just cond_std
- | cls_key == showClassKey = Just cond_std
- | cls_key == readClassKey = Just (cond_std `andCond` cond_noUnliftedArgs)
- | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration)
- | cls_key == ixClassKey = Just (cond_std `andCond` cond_enumOrProduct)
- | cls_key == boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct)
- | cls_key == dataClassKey = Just (cond_mayDeriveDataTypeable `andCond` cond_std `andCond` cond_noUnliftedArgs)
+ | cls_key == eqClassKey = Just cond_std
+ | cls_key == ordClassKey = Just cond_std
+ | cls_key == showClassKey = Just cond_std
+ | cls_key == readClassKey = Just (cond_std `andCond` cond_noUnliftedArgs)
+ | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration)
+ | cls_key == ixClassKey = Just (cond_std `andCond` cond_enumOrProduct)
+ | cls_key == boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct)
+ | cls_key == dataClassKey = Just (cond_mayDeriveDataTypeable `andCond` cond_std `andCond` cond_noUnliftedArgs)
+ | cls_key == functorClassKey = Just (cond_std `andCond` cond_functorOK True)
+ | cls_key == foldableClassKey = Just (cond_std `andCond` cond_functorOK False)
+ | cls_key == traversableClassKey = Just (cond_std `andCond` cond_functorOK False)
| getName cls `elem` typeableClassNames = Just (cond_mayDeriveDataTypeable `andCond` cond_typeableOK)
| otherwise = Nothing
where
cls_key = getUnique cls
-type Condition = (Bool, TyCon) -> Maybe SDoc
- -- Bool is whether or not we are allowed to derive Data and Typeable
+type Condition = (DynFlags, TyCon) -> Maybe SDoc
+ -- first Bool is whether or not we are allowed to derive Data and Typeable
+ -- second Bool is whether or not we are allowed to derive Functor
-- TyCon is the *representation* tycon if the
-- data type is an indexed one
-- Nothing => OK
fam_inst = quotes (pprSourceTyCon rep_tc) <+>
ptext (sLit "is a type family")
+
+functorLikeClassKeys :: [Unique]
+functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey]
+
+cond_functorOK :: Bool -> Condition
+-- OK for Functor class
+-- Currently: (a) at least one argument
+-- (b) don't use argument contravariantly
+-- (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
+-- (d) optionally: don't use function types
+cond_functorOK allowFunctions (dflags, rep_tc)
+ | not (dopt Opt_DeriveFunctor dflags)
+ = Just (ptext (sLit "You need -XDeriveFunctor to derive an instance for this class"))
+ | otherwise
+ = msum (map check con_types)
+ where
+ data_cons = tyConDataCons rep_tc
+ con_types = concatMap dataConOrigArgTys data_cons
+ check = functorLikeTraverse
+ Nothing
+ Nothing
+ (Just covariant)
+ (\x y -> if allowFunctions then x `mplus` y else Just functions)
+ (\_ xs -> msum xs)
+ (\_ x -> x)
+ (Just wrong_arg)
+ (\_ x -> x)
+ (last (tyConTyVars rep_tc))
+ covariant = quotes (pprSourceTyCon rep_tc) <+>
+ ptext (sLit "uses the type variable in a function argument")
+ functions = quotes (pprSourceTyCon rep_tc) <+>
+ ptext (sLit "contains function types")
+ wrong_arg = quotes (pprSourceTyCon rep_tc) <+>
+ ptext (sLit "uses the type variable in an argument other than the last")
+
cond_mayDeriveDataTypeable :: Condition
-cond_mayDeriveDataTypeable (mayDeriveDataTypeable, _)
- | mayDeriveDataTypeable = Nothing
+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]
+ = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
-- Not Read/Show because they respect the type
-- Not Enum, because newtypes are never in Enum
%************************************************************************
\begin{code}
-mkNewTypeEqn :: InstOrigin -> Bool -> Bool -> [Var] -> Class
+mkNewTypeEqn :: InstOrigin -> DynFlags -> [Var] -> Class
-> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
-> Maybe ThetaType
-> TcRn EarlyDerivSpec
-mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving tvs
+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)
| newtype_deriving -> bale_out cant_derive_err -- Too hard, even with newtype deriving
| otherwise -> bale_out non_std_err -- Try newtype deriving!
where
- check_conditions = checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tycon
+ 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 $$
-------------------------------------------------------------------
-- 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
- && eta_ok -- Eta reduction works
+ && 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
-- And the [a] must not mention 'b'. That's all handled
-- by nt_eta_rity.
- 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 eta_ok then
- ptext (sLit "cannot eta-reduce the representation type enough")
- else empty
- ]
+ 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")
\end{code}
Note [Recursive newtypes]
,(showClassKey, gen_Show_binds fix_env)
,(readClassKey, gen_Read_binds fix_env)
,(dataClassKey, gen_Data_binds)
+ ,(functorClassKey, gen_Functor_binds)
+ ,(foldableClassKey, gen_Foldable_binds)
+ ,(traversableClassKey, gen_Traversable_binds)
]
\end{code}