Commit 69f070d8 authored by David Feuer's avatar David Feuer Committed by David Feuer

Deriving for phantom and empty types

Make `Functor`, `Foldable`, and `Traversable` take advantage
of the case where the type parameter is phantom. In this case,

* `fmap _ = coerce`
* `foldMap _ _ = mempty`
* `traverse _ x = pure (coerce x)`

For the sake of consistency and especially simplicity, make other types
with no data constructors behave the same:

* `fmap _ x = case x of`
* `foldMap _ _ = mempty`
* `traverse _ x = pure (case x of)`

Similarly, for `Generic`,

* `to x = case x of`
* `from x = case x of`

Give all derived methods for types without constructors appropriate
arities. For example,

```
    compare _ _ = error ...
```

rather than

```
    compare = error ...
```

Fixes #13117 and #13328

Reviewers: austin, bgamari, RyanGlScott

Reviewed By: RyanGlScott

Subscribers: ekmett, RyanGlScott, rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D3374
parent ff7094e5
...@@ -31,7 +31,7 @@ module TcGenDeriv ( ...@@ -31,7 +31,7 @@ module TcGenDeriv (
mkCoerceClassMethEqn, mkCoerceClassMethEqn,
genAuxBinds, genAuxBinds,
ordOpTbl, boxConTbl, litConTbl, ordOpTbl, boxConTbl, litConTbl,
mkRdrFunBind, error_Expr mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -190,14 +190,9 @@ gen_Eq_binds loc tycon = do ...@@ -190,14 +190,9 @@ gen_Eq_binds loc tycon = do
aux_binds | no_tag_match_cons = emptyBag aux_binds | no_tag_match_cons = emptyBag
| otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
method_binds dflags = listToBag method_binds dflags = unitBag (eq_bind dflags)
[ eq_bind dflags eq_bind dflags = mkFunBindSE 2 loc eq_RDR (map pats_etc pat_match_cons
, ne_bind
]
eq_bind dflags = mk_FunBind loc eq_RDR (map pats_etc pat_match_cons
++ fall_through_eqn dflags) ++ fall_through_eqn dflags)
ne_bind = mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
------------------------------------------------------------------ ------------------------------------------------------------------
pats_etc data_con pats_etc data_con
...@@ -341,7 +336,7 @@ gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff) ...@@ -341,7 +336,7 @@ gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff)
gen_Ord_binds loc tycon = do gen_Ord_binds loc tycon = do
dflags <- getDynFlags dflags <- getDynFlags
return $ if null tycon_data_cons -- No data-cons => invoke bale-out case return $ if null tycon_data_cons -- No data-cons => invoke bale-out case
then ( unitBag $ mk_FunBind loc compare_RDR [] then ( unitBag $ mkFunBindSE 2 loc compare_RDR []
, emptyBag) , emptyBag)
else ( unitBag (mkOrdOp dflags OrdCompare) `unionBags` other_ops dflags else ( unitBag (mkOrdOp dflags OrdCompare) `unionBags` other_ops dflags
, aux_binds) , aux_binds)
...@@ -1124,7 +1119,7 @@ gen_Show_binds get_fixity loc tycon ...@@ -1124,7 +1119,7 @@ gen_Show_binds get_fixity loc tycon
(nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0)))) (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
----------------------------------------------------------------------- -----------------------------------------------------------------------
data_cons = tyConDataCons tycon data_cons = tyConDataCons tycon
shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc data_cons) shows_prec = mkFunBindSE 1 loc showsPrec_RDR (map pats_etc data_cons)
comma_space = nlHsVar showCommaSpace_RDR comma_space = nlHsVar showCommaSpace_RDR
pats_etc data_con pats_etc data_con
...@@ -1345,11 +1340,11 @@ gen_data dflags data_type_name constr_names loc rep_tc ...@@ -1345,11 +1340,11 @@ gen_data dflags data_type_name constr_names loc rep_tc
| otherwise = prefix_RDR | otherwise = prefix_RDR
------------ gfoldl ------------ gfoldl
gfoldl_bind = mk_HRFunBind 2 loc gfoldl_RDR (map gfoldl_eqn data_cons) gfoldl_bind = mkFunBindSE 3 loc gfoldl_RDR (map gfoldl_eqn data_cons)
gfoldl_eqn con gfoldl_eqn con
= ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed], = ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed],
foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed) foldl mk_k_app (z_Expr `nlHsApp` nlHsVar con_name) as_needed)
where where
con_name :: RdrName con_name :: RdrName
con_name = getRdrName con con_name = getRdrName con
...@@ -1357,10 +1352,10 @@ gen_data dflags data_type_name constr_names loc rep_tc ...@@ -1357,10 +1352,10 @@ gen_data dflags data_type_name constr_names loc rep_tc
mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v)) mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
------------ gunfold ------------ gunfold
gunfold_bind = mk_HRFunBind 2 loc gunfold_bind = mk_easy_FunBind loc
gunfold_RDR gunfold_RDR
[([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat], [k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat]
gunfold_rhs)] gunfold_rhs
gunfold_rhs gunfold_rhs
| one_constr = mk_unfold_rhs (head data_cons) -- No need for case | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
...@@ -1369,7 +1364,7 @@ gen_data dflags data_type_name constr_names loc rep_tc ...@@ -1369,7 +1364,7 @@ gen_data dflags data_type_name constr_names loc rep_tc
gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc) gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
mk_unfold_rhs dc = foldr nlHsApp mk_unfold_rhs dc = foldr nlHsApp
(nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc)) (z_Expr `nlHsApp` nlHsVar (getRdrName dc))
(replicate (dataConSourceArity dc) (nlHsVar k_RDR)) (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
mk_unfold_pat dc -- Last one is a wild-pat, to avoid mk_unfold_pat dc -- Last one is a wild-pat, to avoid
...@@ -1381,7 +1376,8 @@ gen_data dflags data_type_name constr_names loc rep_tc ...@@ -1381,7 +1376,8 @@ gen_data dflags data_type_name constr_names loc rep_tc
tag = dataConTag dc tag = dataConTag dc
------------ toConstr ------------ toConstr
toCon_bind = mk_FunBind loc toConstr_RDR (zipWith to_con_eqn data_cons constr_names) toCon_bind = mkFunBindSE 1 loc toConstr_RDR
(zipWith to_con_eqn data_cons constr_names)
to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name) to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name)
------------ dataTypeOf ------------ dataTypeOf
...@@ -1523,10 +1519,13 @@ gen_Lift_binds loc tycon ...@@ -1523,10 +1519,13 @@ gen_Lift_binds loc tycon
, emptyBag) , emptyBag)
| otherwise = (unitBag lift_bind, emptyBag) | otherwise = (unitBag lift_bind, emptyBag)
where where
-- We may want to make mkFunBindSE's error message generation general
-- enough to avoid needing to duplicate its logic here. On the other
-- hand, it may not be worth the trouble.
errorMsg_Expr = nlHsVar error_RDR `nlHsApp` nlHsLit errorMsg_Expr = nlHsVar error_RDR `nlHsApp` nlHsLit
(mkHsString $ "Can't lift value of empty datatype " ++ tycon_str) (mkHsString $ "Can't lift value of empty datatype " ++ tycon_str)
lift_bind = mk_FunBind loc lift_RDR (map pats_etc data_cons) lift_bind = mkFunBindSE 1 loc lift_RDR (map pats_etc data_cons)
data_cons = tyConDataCons tycon data_cons = tyConDataCons tycon
tycon_str = occNameString . nameOccName . tyConName $ tycon tycon_str = occNameString . nameOccName . tyConName $ tycon
...@@ -1656,19 +1655,18 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty ...@@ -1656,19 +1655,18 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
return ( listToBag $ map mk_bind (classMethods cls) return ( listToBag $ map mk_bind (classMethods cls)
, listToBag $ map DerivFamInst atf_insts ) , listToBag $ map DerivFamInst atf_insts )
where where
coerce_RDR = getRdrName coerceId
mk_bind :: Id -> LHsBind RdrName mk_bind :: Id -> LHsBind RdrName
mk_bind meth_id mk_bind meth_id
= mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch
(FunRhs (L loc meth_RDR) Prefix) (FunRhs (L loc meth_RDR) Prefix)
[] rhs_expr] [] rhs_expr]
where where
Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id
meth_RDR = getRdrName meth_id meth_RDR = getRdrName meth_id
rhs_expr = nlHsVar coerce_RDR `nlHsAppType` from_ty rhs_expr = nlHsVar (getRdrName coerceId)
`nlHsAppType` from_ty
`nlHsAppType` to_ty `nlHsAppType` to_ty
`nlHsApp` nlHsVar meth_RDR `nlHsApp` nlHsVar meth_RDR
...@@ -1753,7 +1751,7 @@ fiddling around. ...@@ -1753,7 +1751,7 @@ fiddling around.
genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec
-> (LHsBind RdrName, LSig RdrName) -> (LHsBind RdrName, LSig RdrName)
genAuxBindSpec dflags loc (DerivCon2Tag tycon) genAuxBindSpec dflags loc (DerivCon2Tag tycon)
= (mk_FunBind loc rdr_name eqns, = (mkFunBindSE 0 loc rdr_name eqns,
L loc (TypeSig [L loc rdr_name] sig_ty)) L loc (TypeSig [L loc rdr_name] sig_ty))
where where
rdr_name = con2tag_RDR dflags tycon rdr_name = con2tag_RDR dflags tycon
...@@ -1777,7 +1775,7 @@ genAuxBindSpec dflags loc (DerivCon2Tag tycon) ...@@ -1777,7 +1775,7 @@ genAuxBindSpec dflags loc (DerivCon2Tag tycon)
(toInteger ((dataConTag con) - fIRST_TAG)))) (toInteger ((dataConTag con) - fIRST_TAG))))
genAuxBindSpec dflags loc (DerivTag2Con tycon) genAuxBindSpec dflags loc (DerivTag2Con tycon)
= (mk_FunBind loc rdr_name = (mkFunBindSE 0 loc rdr_name
[([nlConVarPat intDataCon_RDR [a_RDR]], [([nlConVarPat intDataCon_RDR [a_RDR]],
nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)], nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
L loc (TypeSig [L loc rdr_name] sig_ty)) L loc (TypeSig [L loc rdr_name] sig_ty))
...@@ -1841,34 +1839,60 @@ mkParentType tc ...@@ -1841,34 +1839,60 @@ mkParentType tc
************************************************************************ ************************************************************************
-} -}
mk_FunBind :: SrcSpan -> RdrName -- | Make a function binding. If no equations are given, produce a function
-> [([LPat RdrName], LHsExpr RdrName)] -- with the given arity that produces a stock error.
-> LHsBind RdrName mkFunBindSE :: Arity -> SrcSpan -> RdrName
mk_FunBind = mk_HRFunBind 0 -- by using mk_FunBind and not mk_HRFunBind,
-- the caller says that the Void case needs no
-- patterns
-- | This variant of 'mk_FunBind' puts an 'Arity' number of wildcards before
-- the "=" in the empty-data-decl case. This is necessary if the function
-- has a higher-rank type, like foldl. (See deriving/should_compile/T4302)
mk_HRFunBind :: Arity -> SrcSpan -> RdrName
-> [([LPat RdrName], LHsExpr RdrName)] -> [([LPat RdrName], LHsExpr RdrName)]
-> LHsBind RdrName -> LHsBind RdrName
mk_HRFunBind arity loc fun pats_and_exprs mkFunBindSE arity loc fun pats_and_exprs
= mkHRRdrFunBind arity (L loc fun) matches = mkRdrFunBindSE arity (L loc fun) matches
where where
matches = [mkMatch (FunRhs (L loc fun) Prefix) p e matches = [mkMatch (FunRhs (L loc fun) Prefix) p e
(noLoc emptyLocalBinds) (noLoc emptyLocalBinds)
| (p,e) <-pats_and_exprs] | (p,e) <-pats_and_exprs]
mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
mkRdrFunBind = mkHRRdrFunBind 0 mkRdrFunBind fun@(L loc _fun_rdr) matches
= L loc (mkFunBind fun matches)
-- | Produces a function binding. When no equations are given, it generates
-- a binding of the given arity and an empty case expression
-- for the last argument that it passes to the given function to produce
-- the right-hand side.
mkRdrFunBindEC :: Arity
-> (LHsExpr RdrName -> LHsExpr RdrName)
-> Located RdrName
-> [LMatch RdrName (LHsExpr RdrName)]
-> LHsBind RdrName
mkRdrFunBindEC arity catch_all
fun@(L loc _fun_rdr) matches = L loc (mkFunBind fun matches')
where
-- Catch-all eqn looks like
-- fmap _ z = case z of {}
-- or
-- traverse _ z = pure (case z of)
-- or
-- foldMap _ z = mempty
-- It's needed if there no data cons at all,
-- which can happen with -XEmptyDataDecls
-- See Trac #4302
matches' = if null matches
then [mkMatch (FunRhs fun Prefix)
(replicate (arity - 1) nlWildPat ++ [z_Pat])
(catch_all $ nlHsCase z_Expr [])
(noLoc emptyLocalBinds)]
else matches
mkHRRdrFunBind :: Arity -> Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName -- | Produces a function binding. When there are no equations, it generates
mkHRRdrFunBind arity fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches') -- a binding with the given arity that produces an error based on the name of
-- the type of the last argument.
mkRdrFunBindSE :: Arity -> Located RdrName ->
[LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
mkRdrFunBindSE arity
fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
where where
-- Catch-all eqn looks like -- Catch-all eqn looks like
-- fmap = error "Void fmap" -- compare _ _ = error "Void compare"
-- It's needed if there no data cons at all, -- It's needed if there no data cons at all,
-- which can happen with -XEmptyDataDecls -- which can happen with -XEmptyDataDecls
-- See Trac #4302 -- See Trac #4302
...@@ -1879,6 +1903,7 @@ mkHRRdrFunBind arity fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches' ...@@ -1879,6 +1903,7 @@ mkHRRdrFunBind arity fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches'
else matches else matches
str = "Void " ++ occNameString (rdrNameOcc fun_rdr) str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
box :: String -- The class involved box :: String -- The class involved
-> TyCon -- The tycon involved -> TyCon -- The tycon involved
-> LHsExpr RdrName -- The argument -> LHsExpr RdrName -- The argument
...@@ -2079,11 +2104,12 @@ as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ...@@ -2079,11 +2104,12 @@ as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) ..
bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ] cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
a_Expr, b_Expr, c_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr, a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr,
true_Expr :: LHsExpr RdrName true_Expr :: LHsExpr RdrName
a_Expr = nlHsVar a_RDR a_Expr = nlHsVar a_RDR
b_Expr = nlHsVar b_RDR b_Expr = nlHsVar b_RDR
c_Expr = nlHsVar c_RDR c_Expr = nlHsVar c_RDR
z_Expr = nlHsVar z_RDR
ltTag_Expr = nlHsVar ltTag_RDR ltTag_Expr = nlHsVar ltTag_RDR
eqTag_Expr = nlHsVar eqTag_RDR eqTag_Expr = nlHsVar eqTag_RDR
gtTag_Expr = nlHsVar gtTag_RDR gtTag_Expr = nlHsVar gtTag_RDR
......
...@@ -33,6 +33,7 @@ import Type ...@@ -33,6 +33,7 @@ import Type
import Util import Util
import Var import Var
import VarSet import VarSet
import MkId (coerceId)
import Data.Maybe (catMaybes, isJust) import Data.Maybe (catMaybes, isJust)
...@@ -124,12 +125,27 @@ It is better to produce too many lambdas than to eta expand, see ticket #7436. ...@@ -124,12 +125,27 @@ It is better to produce too many lambdas than to eta expand, see ticket #7436.
-} -}
gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
-- When the argument is phantom, we can use fmap _ = coerce
-- See Note [Phantom types with Functor, Foldable, and Traversable]
gen_Functor_binds loc tycon
| Phantom <- last (tyConRoles tycon)
= (unitBag fmap_bind, emptyBag)
where
fmap_name = L loc fmap_RDR
fmap_bind = mkRdrFunBind fmap_name fmap_eqns
fmap_eqns = [mkSimpleMatch fmap_match_ctxt
[nlWildPat]
coerce_Expr]
fmap_match_ctxt = FunRhs fmap_name Prefix
gen_Functor_binds loc tycon gen_Functor_binds loc tycon
= (listToBag [fmap_bind, replace_bind], emptyBag) = (listToBag [fmap_bind, replace_bind], emptyBag)
where where
data_cons = tyConDataCons tycon data_cons = tyConDataCons tycon
fmap_name = L loc fmap_RDR fmap_name = L loc fmap_RDR
fmap_bind = mkRdrFunBind fmap_name fmap_eqns
-- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
fmap_bind = mkRdrFunBindEC 2 id fmap_name fmap_eqns
fmap_match_ctxt = FunRhs fmap_name Prefix fmap_match_ctxt = FunRhs fmap_name Prefix
fmap_eqn con = flip evalState bs_RDRs $ fmap_eqn con = flip evalState bs_RDRs $
...@@ -137,11 +153,7 @@ gen_Functor_binds loc tycon ...@@ -137,11 +153,7 @@ gen_Functor_binds loc tycon
where where
parts = sequence $ foldDataConArgs ft_fmap con parts = sequence $ foldDataConArgs ft_fmap con
fmap_eqns fmap_eqns = map fmap_eqn data_cons
| null data_cons = [mkSimpleMatch fmap_match_ctxt
[nlWildPat, nlWildPat]
(error_Expr "Void fmap")]
| otherwise = map fmap_eqn data_cons
ft_fmap :: FFoldType (State [RdrName] (LHsExpr RdrName)) ft_fmap :: FFoldType (State [RdrName] (LHsExpr RdrName))
ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x
...@@ -161,12 +173,14 @@ gen_Functor_binds loc tycon ...@@ -161,12 +173,14 @@ gen_Functor_binds loc tycon
, ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g , ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g
-- fmap f = fmap g -- fmap f = fmap g
, ft_forall = \_ g -> g , ft_forall = \_ g -> g
, ft_bad_app = panic "in other argument" , ft_bad_app = panic "in other argument in ft_fmap"
, ft_co_var = panic "contravariant" } , ft_co_var = panic "contravariant in ft_fmap" }
-- See Note [deriving <$] -- See Note [deriving <$]
replace_name = L loc replace_RDR replace_name = L loc replace_RDR
replace_bind = mkRdrFunBind replace_name replace_eqns
-- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
replace_bind = mkRdrFunBindEC 2 id replace_name replace_eqns
replace_match_ctxt = FunRhs replace_name Prefix replace_match_ctxt = FunRhs replace_name Prefix
replace_eqn con = flip evalState bs_RDRs $ replace_eqn con = flip evalState bs_RDRs $
...@@ -174,11 +188,7 @@ gen_Functor_binds loc tycon ...@@ -174,11 +188,7 @@ gen_Functor_binds loc tycon
where where
parts = traverse (fmap replace) $ foldDataConArgs ft_replace con parts = traverse (fmap replace) $ foldDataConArgs ft_replace con
replace_eqns replace_eqns = map replace_eqn data_cons
| null data_cons = [mkSimpleMatch replace_match_ctxt
[nlWildPat, nlWildPat]
(error_Expr "Void <$")]
| otherwise = map replace_eqn data_cons
ft_replace :: FFoldType (State [RdrName] Replacer) ft_replace :: FFoldType (State [RdrName] Replacer)
ft_replace = FT { ft_triv = fmap Nested $ mkSimpleLam $ \x -> return x ft_replace = FT { ft_triv = fmap Nested $ mkSimpleLam $ \x -> return x
...@@ -205,8 +215,8 @@ gen_Functor_binds loc tycon ...@@ -205,8 +215,8 @@ gen_Functor_binds loc tycon
nlHsApp replace_Expr z_Expr nlHsApp replace_Expr z_Expr
-- (p <$) = fmap (p <$) -- (p <$) = fmap (p <$)
, ft_forall = \_ g -> g , ft_forall = \_ g -> g
, ft_bad_app = panic "in other argument" , ft_bad_app = panic "in other argument in ft_replace"
, ft_co_var = panic "contravariant" } , ft_co_var = panic "contravariant in ft_replace" }
-- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ... -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
match_for_con :: HsMatchContext RdrName match_for_con :: HsMatchContext RdrName
...@@ -394,8 +404,8 @@ deepSubtypesContaining tv ...@@ -394,8 +404,8 @@ deepSubtypesContaining tv
, ft_fun = (++) , ft_fun = (++)
, ft_tup = \_ xs -> concat xs , ft_tup = \_ xs -> concat xs
, ft_ty_app = (:) , ft_ty_app = (:)
, ft_bad_app = panic "in other argument" , ft_bad_app = panic "in other argument in deepSubtypesContaining"
, ft_co_var = panic "contravariant" , ft_co_var = panic "contravariant in deepSubtypesContaining"
, ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs }) , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs })
...@@ -456,7 +466,8 @@ mkSimpleConMatch ctxt fold extra_pats con insides = do ...@@ -456,7 +466,8 @@ mkSimpleConMatch ctxt fold extra_pats con insides = do
let pat = if null vars_needed let pat = if null vars_needed
then bare_pat then bare_pat
else nlParPat bare_pat else nlParPat bare_pat
rhs <- fold con_name (zipWith nlHsApp insides (map nlHsVar vars_needed)) rhs <- fold con_name
(zipWith (\i v -> i `nlHsApp` nlHsVar v) insides vars_needed)
return $ mkMatch ctxt (extra_pats ++ [pat]) rhs return $ mkMatch ctxt (extra_pats ++ [pat]) rhs
(noLoc emptyLocalBinds) (noLoc emptyLocalBinds)
...@@ -492,21 +503,19 @@ mkSimpleConMatch2 ctxt fold extra_pats con insides = do ...@@ -492,21 +503,19 @@ mkSimpleConMatch2 ctxt fold extra_pats con insides = do
-- Make sure to zip BEFORE invoking catMaybes. We want the variable -- Make sure to zip BEFORE invoking catMaybes. We want the variable
-- indicies in each expression to match up with the argument indices -- indicies in each expression to match up with the argument indices
-- in con_expr (defined below). -- in con_expr (defined below).
exps = catMaybes $ zipWith (\i v -> (`nlHsApp` v) <$> i) exps = catMaybes $ zipWith (\i v -> (`nlHsApp` nlHsVar v) <$> i)
insides (map nlHsVar vars_needed) insides vars_needed
-- An element of argTysTyVarInfo is True if the constructor argument -- An element of argTysTyVarInfo is True if the constructor argument
-- with the same index has a type which mentions the last type -- with the same index has a type which mentions the last type
-- variable. -- variable.
argTysTyVarInfo = map isJust insides argTysTyVarInfo = map isJust insides
(asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_RDRs (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_Vars
con_expr con_expr
| null asWithTyVar = nlHsApps con_name $ map nlHsVar asWithoutTyVar | null asWithTyVar = nlHsApps con_name asWithoutTyVar
| otherwise = | otherwise =
let bs = filterByList argTysTyVarInfo bs_RDRs let bs = filterByList argTysTyVarInfo bs_RDRs
vars = filterByLists argTysTyVarInfo vars = filterByLists argTysTyVarInfo bs_Vars as_Vars
(map nlHsVar bs_RDRs)
(map nlHsVar as_RDRs)
in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars) in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars)
rhs <- fold con_expr exps rhs <- fold con_expr exps
...@@ -590,7 +599,25 @@ See Note [DeriveFoldable with ExistentialQuantification]. ...@@ -590,7 +599,25 @@ See Note [DeriveFoldable with ExistentialQuantification].
-} -}
gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
-- When the parameter is phantom, we can use foldMap _ _ = mempty
-- See Note [Phantom types with Functor, Foldable, and Traversable]
gen_Foldable_binds loc tycon
| Phantom <- last (tyConRoles tycon)
= (unitBag foldMap_bind, emptyBag)
where
foldMap_name = L loc foldMap_RDR
foldMap_bind = mkRdrFunBind foldMap_name foldMap_eqns
foldMap_eqns = [mkSimpleMatch foldMap_match_ctxt
[nlWildPat, nlWildPat]
mempty_Expr]
foldMap_match_ctxt = FunRhs foldMap_name Prefix
gen_Foldable_binds loc tycon gen_Foldable_binds loc tycon
| null data_cons -- There's no real point producing anything but
-- foldMap for a type with no constructors.
= (unitBag foldMap_bind, emptyBag)
| otherwise
= (listToBag [foldr_bind, foldMap_bind], emptyBag) = (listToBag [foldr_bind, foldMap_bind], emptyBag)
where where
data_cons = tyConDataCons tycon data_cons = tyConDataCons tycon
...@@ -602,7 +629,14 @@ gen_Foldable_binds loc tycon ...@@ -602,7 +629,14 @@ gen_Foldable_binds loc tycon
where where
parts = sequence $ foldDataConArgs ft_foldr con parts = sequence $ foldDataConArgs ft_foldr con
foldMap_bind = mkRdrFunBind (L loc foldMap_RDR) (map foldMap_eqn data_cons) foldMap_name = L loc foldMap_RDR
-- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
foldMap_bind = mkRdrFunBindEC 2 (const mempty_Expr)
foldMap_name foldMap_eqns
foldMap_eqns = map foldMap_eqn data_cons
foldMap_eqn con foldMap_eqn con
= evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs
where where
...@@ -629,9 +663,9 @@ gen_Foldable_binds loc tycon ...@@ -629,9 +663,9 @@ gen_Foldable_binds loc tycon
nlHsApps foldable_foldr_RDR [gg',z,x]) gg nlHsApps foldable_foldr_RDR [gg',z,x]) gg
-- foldr f = (\x z -> foldr g z x) -- foldr f = (\x z -> foldr g z x)
, ft_forall = \_ g -> g , ft_forall = \_ g -> g
, ft_co_var = panic "contravariant" , ft_co_var = panic "contravariant in ft_foldr"
, ft_fun = panic "function" , ft_fun = panic "function in ft_foldr"
, ft_bad_app = panic "in other argument" } , ft_bad_app = panic "in other argument in ft_foldr" }
match_foldr :: LHsExpr RdrName match_foldr :: LHsExpr RdrName
-> [LPat RdrName] -> [LPat RdrName]
...@@ -659,9 +693,9 @@ gen_Foldable_binds loc tycon ...@@ -659,9 +693,9 @@ gen_Foldable_binds loc tycon
, ft_ty_app = \_ g -> fmap (nlHsApp foldMap_Expr) <$> g , ft_ty_app = \_ g -> fmap (nlHsApp foldMap_Expr) <$> g
-- foldMap f = foldMap g -- foldMap f = foldMap g
, ft_forall = \_ g -> g , ft_forall = \_ g -> g
, ft_co_var = panic "contravariant"