Commit 1ef81a94 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Further wibbles to 'deriving' for functor-like things

parent 6cd825dc
......@@ -663,39 +663,40 @@ mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
| otherwise
= do { dfun_name <- new_dfun_name cls tycon
; loc <- getSrcSpanM
; let ordinary_constraints_simple
; let ordinary_constraints
= [ 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
-- constraints on all subtypes for classes like Functor
ordinary_constraints_deep
= [ mkClassPred cls [deept_ty]
| data_con <- tyConDataCons rep_tc,
arg_ty <- ASSERT( isVanillaDataCon data_con )
dataConInstOrigArgTys data_con (rep_tc_args++[mkTyVarTy dummy_ty]),
deept_ty <- deepSubtypesContaining dummy_ty arg_ty,
not (isUnLiftedType deept_ty) ]
where dummy_ty = last (tyConTyVars tycon) -- don't substitute the last var, this might not be a good idea
ordinary_constraints
| getUnique cls == functorClassKey = ordinary_constraints_deep
| getUnique cls == foldableClassKey = ordinary_constraints_deep
| getUnique cls == traversableClassKey = ordinary_constraints_deep
| otherwise = ordinary_constraints_simple
-- 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]
nonfree_tycon_vars = dropTail (classArity cls) (tyConTyVars rep_tc)
stupid_subst = zipTopTvSubst nonfree_tycon_vars rep_tc_args
stupid_constraints = substTheta stupid_subst (tyConStupidTheta rep_tc)
subst = zipTopTvSubst rep_tc_tvs all_rep_tc_args
stupid_constraints = substTheta subst (tyConStupidTheta rep_tc)
all_constraints = stupid_constraints ++ sc_constraints ++ ordinary_constraints
......@@ -706,7 +707,8 @@ mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
, 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
......@@ -766,17 +768,17 @@ nonStdErr cls = quotes (ppr cls) <+> ptext (sLit "is not a derivable class")
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 == functorClassKey = Just (cond_mayDeriveFunctor `andCond` cond_std `andCond` cond_functorOK True)
| cls_key == foldableClassKey = Just (cond_mayDeriveFunctor `andCond` cond_std `andCond` cond_functorOK False)
| cls_key == traversableClassKey = Just (cond_mayDeriveFunctor `andCond` cond_std `andCond` cond_functorOK False)
| 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
......@@ -865,13 +867,21 @@ cond_typeableOK (_, rep_tc)
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 (_, rep_tc) = msum (map check con_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
......@@ -899,17 +909,10 @@ cond_mayDeriveDataTypeable (dflags, _)
where
why = ptext (sLit "You need -XDeriveDataTypeable to derive an instance for this class")
cond_mayDeriveFunctor :: Condition
cond_mayDeriveFunctor (dflags, _)
| dopt Opt_DeriveFunctor dflags = Nothing
| otherwise = Just why
where
why = ptext (sLit "You need -XDeriveFunctor 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
......
......@@ -1240,10 +1240,10 @@ rather than just one level, as we typically do.
What about types with more than one type parameter? In general, we only
derive Functor for the last position:
data S a b = S1 [b] | S2 a
data S a b = S1 [b] | S2 (a, T a b)
instance Functor (S a) where
fmap f (S1 bs) = S1 (fmap f bs)
fmap f (S2 a) = S2 a
fmap f (S1 bs) = S1 (fmap f bs)
fmap f (S2 (p,q)) = S2 (a, fmap f q)
However, we have special cases for
- tuples
......@@ -1319,8 +1319,8 @@ functorLikeTraverse :: a -- ^ Case: does not contain variable
-> a -- ^ Case: the variable itself, contravariantly
-> (a -> a -> a) -- ^ Case: function type
-> (Boxity -> [a] -> a) -- ^ Case: tuple type
-> (Type -> a -> a) -- ^ Case: other tycon, variable only in last argument
-> a -- ^ Case: other tycon, variable only in last argument
-> (Type -> a -> a) -- ^ Case: type app, variable only in last argument
-> a -- ^ Case: type app, variable other than in last argument
-> (TcTyVar -> a -> a) -- ^ Case: forall type
-> TcTyVar -- ^ Variable to look for
-> Type -- ^ Type to process
......@@ -1334,22 +1334,23 @@ functorLikeTraverse caseTrivial caseVar caseCoVar caseFun caseTuple caseTyApp ca
go co (FunTy x y) | xc || yc = (caseFun xr yr,True)
where (xr,xc) = go (not co) x
(yr,yc) = go co y
go co (AppTy x y) | xc = (caseWrongArg,True)
| yc = (caseTyApp x yr,True)
go co (AppTy x y) | xc = (caseWrongArg, True)
| yc = (caseTyApp x yr, True)
where (_, xc) = go co x
(yr,yc) = go co y
go co ty@(TyConApp con args)
| isTupleTyCon con = (caseTuple (tupleTyConBoxity con) xrs,True)
| null args = (caseTrivial,False)
| or (init xcs) = (caseWrongArg,True)
| (last xcs) = (caseTyApp (fst (splitAppTy ty)) (last xrs),True)
| isTupleTyCon con = (caseTuple (tupleTyConBoxity con) xrs,True)
| null args = (caseTrivial,False) -- T
| or (init xcs) = (caseWrongArg,True) -- T (..var..) ty
| last xcs = -- T (..no var..) ty
(caseTyApp (fst (splitAppTy ty)) (last xrs),True)
where (xrs,xcs) = unzip (map (go co) args)
go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True)
where (xr,xc) = go co x
go _ _ = (caseTrivial,False)
go _ _ = (caseTrivial,False)
-- return all subtypes of ty that contain var somewhere
-- these are the things that should appear in instance constraints
-- Return all syntactic subterms of ty that contain var somewhere
-- These are the things that should appear in instance constraints
deepSubtypesContaining :: TcTyVar -> TcType -> [TcType]
deepSubtypesContaining = functorLikeTraverse
[]
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment