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 (
mkCoerceClassMethEqn,
genAuxBinds,
ordOpTbl, boxConTbl, litConTbl,
mkRdrFunBind, error_Expr
mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr
) where
#include "HsVersions.h"
......@@ -190,14 +190,9 @@ gen_Eq_binds loc tycon = do
aux_binds | no_tag_match_cons = emptyBag
| otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
method_binds dflags = listToBag
[ eq_bind dflags
, ne_bind
]
eq_bind dflags = mk_FunBind loc eq_RDR (map pats_etc pat_match_cons
method_binds dflags = unitBag (eq_bind dflags)
eq_bind dflags = mkFunBindSE 2 loc eq_RDR (map pats_etc pat_match_cons
++ 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
......@@ -341,7 +336,7 @@ gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff)
gen_Ord_binds loc tycon = do
dflags <- getDynFlags
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)
else ( unitBag (mkOrdOp dflags OrdCompare) `unionBags` other_ops dflags
, aux_binds)
......@@ -1124,7 +1119,7 @@ gen_Show_binds get_fixity loc tycon
(nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
-----------------------------------------------------------------------
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
pats_etc data_con
......@@ -1345,11 +1340,11 @@ gen_data dflags data_type_name constr_names loc rep_tc
| otherwise = prefix_RDR
------------ 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
= ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
= ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed],
foldl mk_k_app (z_Expr `nlHsApp` nlHsVar con_name) as_needed)
where
con_name :: RdrName
con_name = getRdrName con
......@@ -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))
------------ gunfold
gunfold_bind = mk_HRFunBind 2 loc
gunfold_bind = mk_easy_FunBind loc
gunfold_RDR
[([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
gunfold_rhs)]
[k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat]
gunfold_rhs
gunfold_rhs
| 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
gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
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))
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
tag = dataConTag dc
------------ 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)
------------ dataTypeOf
......@@ -1523,10 +1519,13 @@ gen_Lift_binds loc tycon
, emptyBag)
| otherwise = (unitBag lift_bind, emptyBag)
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
(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
tycon_str = occNameString . nameOccName . tyConName $ tycon
......@@ -1656,19 +1655,18 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
return ( listToBag $ map mk_bind (classMethods cls)
, listToBag $ map DerivFamInst atf_insts )
where
coerce_RDR = getRdrName coerceId
mk_bind :: Id -> LHsBind RdrName
mk_bind meth_id
= mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch
(FunRhs (L loc meth_RDR) Prefix)
[] rhs_expr]
(FunRhs (L loc meth_RDR) Prefix)
[] rhs_expr]
where
Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty 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
`nlHsApp` nlHsVar meth_RDR
......@@ -1753,7 +1751,7 @@ fiddling around.
genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec
-> (LHsBind RdrName, LSig RdrName)
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))
where
rdr_name = con2tag_RDR dflags tycon
......@@ -1777,7 +1775,7 @@ genAuxBindSpec dflags loc (DerivCon2Tag tycon)
(toInteger ((dataConTag con) - fIRST_TAG))))
genAuxBindSpec dflags loc (DerivTag2Con tycon)
= (mk_FunBind loc rdr_name
= (mkFunBindSE 0 loc rdr_name
[([nlConVarPat intDataCon_RDR [a_RDR]],
nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
L loc (TypeSig [L loc rdr_name] sig_ty))
......@@ -1841,34 +1839,60 @@ mkParentType tc
************************************************************************
-}
mk_FunBind :: SrcSpan -> RdrName
-> [([LPat RdrName], LHsExpr RdrName)]
-> LHsBind 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
-- | Make a function binding. If no equations are given, produce a function
-- with the given arity that produces a stock error.
mkFunBindSE :: Arity -> SrcSpan -> RdrName
-> [([LPat RdrName], LHsExpr RdrName)]
-> LHsBind RdrName
mk_HRFunBind arity loc fun pats_and_exprs
= mkHRRdrFunBind arity (L loc fun) matches
mkFunBindSE arity loc fun pats_and_exprs
= mkRdrFunBindSE arity (L loc fun) matches
where
matches = [mkMatch (FunRhs (L loc fun) Prefix) p e
(noLoc emptyLocalBinds)
| (p,e) <-pats_and_exprs]
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
mkHRRdrFunBind arity fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
-- | Produces a function binding. When there are no equations, it generates
-- 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
-- Catch-all eqn looks like
-- fmap = error "Void fmap"
-- compare _ _ = error "Void compare"
-- It's needed if there no data cons at all,
-- which can happen with -XEmptyDataDecls
-- See Trac #4302
......@@ -1879,6 +1903,7 @@ mkHRRdrFunBind arity fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches'
else matches
str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
box :: String -- The class involved
-> TyCon -- The tycon involved
-> LHsExpr RdrName -- The argument
......@@ -2079,11 +2104,12 @@ as_RDRs = [ mkVarUnqual (mkFastString ("a"++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) .. ] ]
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
a_Expr = nlHsVar a_RDR
b_Expr = nlHsVar b_RDR
c_Expr = nlHsVar c_RDR
z_Expr = nlHsVar z_RDR
ltTag_Expr = nlHsVar ltTag_RDR
eqTag_Expr = nlHsVar eqTag_RDR
gtTag_Expr = nlHsVar gtTag_RDR
......
......@@ -33,6 +33,7 @@ import Type
import Util
import Var
import VarSet
import MkId (coerceId)
import Data.Maybe (catMaybes, isJust)
......@@ -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)
-- 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
= (listToBag [fmap_bind, replace_bind], emptyBag)
where
data_cons = tyConDataCons tycon
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_eqn con = flip evalState bs_RDRs $
......@@ -137,11 +153,7 @@ gen_Functor_binds loc tycon
where
parts = sequence $ foldDataConArgs ft_fmap con
fmap_eqns
| null data_cons = [mkSimpleMatch fmap_match_ctxt
[nlWildPat, nlWildPat]
(error_Expr "Void fmap")]
| otherwise = map fmap_eqn data_cons
fmap_eqns = map fmap_eqn data_cons
ft_fmap :: FFoldType (State [RdrName] (LHsExpr RdrName))
ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x
......@@ -161,12 +173,14 @@ gen_Functor_binds loc tycon
, ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g
-- fmap f = fmap g
, ft_forall = \_ g -> g
, ft_bad_app = panic "in other argument"
, ft_co_var = panic "contravariant" }
, ft_bad_app = panic "in other argument in ft_fmap"
, ft_co_var = panic "contravariant in ft_fmap" }
-- See Note [deriving <$]
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_eqn con = flip evalState bs_RDRs $
......@@ -174,11 +188,7 @@ gen_Functor_binds loc tycon
where
parts = traverse (fmap replace) $ foldDataConArgs ft_replace con
replace_eqns
| null data_cons = [mkSimpleMatch replace_match_ctxt
[nlWildPat, nlWildPat]
(error_Expr "Void <$")]
| otherwise = map replace_eqn data_cons
replace_eqns = map replace_eqn data_cons
ft_replace :: FFoldType (State [RdrName] Replacer)
ft_replace = FT { ft_triv = fmap Nested $ mkSimpleLam $ \x -> return x
......@@ -205,8 +215,8 @@ gen_Functor_binds loc tycon
nlHsApp replace_Expr z_Expr
-- (p <$) = fmap (p <$)
, ft_forall = \_ g -> g
, ft_bad_app = panic "in other argument"
, ft_co_var = panic "contravariant" }
, ft_bad_app = panic "in other argument in ft_replace"
, ft_co_var = panic "contravariant in ft_replace" }
-- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
match_for_con :: HsMatchContext RdrName
......@@ -394,8 +404,8 @@ deepSubtypesContaining tv
, ft_fun = (++)
, ft_tup = \_ xs -> concat xs
, ft_ty_app = (:)
, ft_bad_app = panic "in other argument"
, ft_co_var = panic "contravariant"
, ft_bad_app = panic "in other argument in deepSubtypesContaining"
, ft_co_var = panic "contravariant in deepSubtypesContaining"
, ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs })
......@@ -456,7 +466,8 @@ mkSimpleConMatch ctxt fold extra_pats con insides = do
let pat = if null vars_needed
then 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
(noLoc emptyLocalBinds)
......@@ -492,21 +503,19 @@ mkSimpleConMatch2 ctxt fold extra_pats con insides = do
-- Make sure to zip BEFORE invoking catMaybes. We want the variable
-- indicies in each expression to match up with the argument indices
-- in con_expr (defined below).
exps = catMaybes $ zipWith (\i v -> (`nlHsApp` v) <$> i)
insides (map nlHsVar vars_needed)
exps = catMaybes $ zipWith (\i v -> (`nlHsApp` nlHsVar v) <$> i)
insides vars_needed
-- An element of argTysTyVarInfo is True if the constructor argument
-- with the same index has a type which mentions the last type
-- variable.
argTysTyVarInfo = map isJust insides
(asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_RDRs
(asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_Vars
con_expr
| null asWithTyVar = nlHsApps con_name $ map nlHsVar asWithoutTyVar
| null asWithTyVar = nlHsApps con_name asWithoutTyVar
| otherwise =
let bs = filterByList argTysTyVarInfo bs_RDRs
vars = filterByLists argTysTyVarInfo
(map nlHsVar bs_RDRs)
(map nlHsVar as_RDRs)
vars = filterByLists argTysTyVarInfo bs_Vars as_Vars
in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars)
rhs <- fold con_expr exps
......@@ -590,7 +599,25 @@ See Note [DeriveFoldable with ExistentialQuantification].
-}
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
| 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)
where
data_cons = tyConDataCons tycon
......@@ -602,7 +629,14 @@ gen_Foldable_binds loc tycon
where
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
= evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs
where
......@@ -629,9 +663,9 @@ gen_Foldable_binds loc tycon
nlHsApps foldable_foldr_RDR [gg',z,x]) gg
-- foldr f = (\x z -> foldr g z x)
, ft_forall = \_ g -> g
, ft_co_var = panic "contravariant"
, ft_fun = panic "function"
, ft_bad_app = panic "in other argument" }
, ft_co_var = panic "contravariant in ft_foldr"
, ft_fun = panic "function in ft_foldr"
, ft_bad_app = panic "in other argument in ft_foldr" }
match_foldr :: LHsExpr RdrName
-> [LPat RdrName]
......@@ -659,9 +693,9 @@ gen_Foldable_binds loc tycon
, ft_ty_app = \_ g -> fmap (nlHsApp foldMap_Expr) <$> g
-- foldMap f = foldMap g
, ft_forall = \_ g -> g
, ft_co_var = panic "contravariant"
, ft_fun = panic "function"
, ft_bad_app = panic "in other argument" }
, ft_co_var = panic "contravariant in ft_foldMap"
, ft_fun = panic "function in ft_foldMap"
, ft_bad_app = panic "in other argument in ft_foldMap" }
match_foldMap :: [LPat RdrName]
-> DataCon
......@@ -715,13 +749,31 @@ See Note [Generated code for DeriveFoldable and DeriveTraversable].
-}
gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
-- When the argument is phantom, we can use traverse = pure . coerce
-- See Note [Phantom types with Functor, Foldable, and Traversable]
gen_Traversable_binds loc tycon
| Phantom <- last (tyConRoles tycon)
= (unitBag traverse_bind, emptyBag)
where
traverse_name = L loc traverse_RDR
traverse_bind = mkRdrFunBind traverse_name traverse_eqns
traverse_eqns =
[mkSimpleMatch traverse_match_ctxt
[nlWildPat, z_Pat]
(nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])]
traverse_match_ctxt = FunRhs traverse_name Prefix
gen_Traversable_binds loc tycon
= (unitBag traverse_bind, emptyBag)
where
data_cons = tyConDataCons tycon
traverse_bind = mkRdrFunBind (L loc traverse_RDR) eqns
eqns = map traverse_eqn data_cons
traverse_name = L loc traverse_RDR
-- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
traverse_bind = mkRdrFunBindEC 2 (nlHsApp pure_Expr)
traverse_name traverse_eqns
traverse_eqns = map traverse_eqn data_cons
traverse_eqn con
= evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
where
......@@ -745,9 +797,9 @@ gen_Traversable_binds loc tycon
, ft_ty_app = \_ g -> fmap (nlHsApp traverse_Expr) <$> g
-- traverse f = traverse g
, ft_forall = \_ g -> g
, ft_co_var = panic "contravariant"
, ft_fun = panic "function"
, ft_bad_app = panic "in other argument" }
, ft_co_var = panic "contravariant in ft_trav"
, ft_fun = panic "function in ft_trav"
, ft_bad_app = panic "in other argument in ft_trav" }
-- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)
-- (g2 a2) <*> ...
......@@ -769,7 +821,7 @@ gen_Traversable_binds loc tycon
-----------------------------------------------------------------------
f_Expr, z_Expr, fmap_Expr, replace_Expr, mempty_Expr, foldMap_Expr,
traverse_Expr :: LHsExpr RdrName
traverse_Expr, coerce_Expr, pure_Expr :: LHsExpr RdrName
f_Expr = nlHsVar f_RDR
z_Expr = nlHsVar z_RDR
fmap_Expr = nlHsVar fmap_RDR
......@@ -777,6 +829,8 @@ replace_Expr = nlHsVar replace_RDR
mempty_Expr = nlHsVar mempty_RDR
foldMap_Expr = nlHsVar foldMap_RDR
traverse_Expr = nlHsVar traverse_RDR
coerce_Expr = nlHsVar (getRdrName coerceId)
pure_Expr = nlHsVar pure_RDR
f_RDR, z_RDR :: RdrName
f_RDR = mkVarUnqual (fsLit "f")
......@@ -786,6 +840,10 @@ as_RDRs, bs_RDRs :: [RdrName]
as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
as_Vars, bs_Vars :: [LHsExpr RdrName]
as_Vars = map nlHsVar as_RDRs
bs_Vars = map nlHsVar bs_RDRs
f_Pat, z_Pat :: LPat RdrName
f_Pat = nlVarPat f_RDR
z_Pat = nlVarPat z_RDR
......@@ -1021,4 +1079,84 @@ decide not to do so because:
which does not typecheck, since GHC cannot unify the rank-2 type variables
in the types of b and (fmap f a).
Note [Phantom types with Functor, Foldable, and Traversable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Given a type F :: * -> * whose type argument has a phantom role, we can always
produce lawful Functor and Traversable instances using
fmap _ = coerce
traverse _ = pure . coerce
Indeed, these are equivalent to any *strictly lawful* instances one could
write, except that this definition of 'traverse' may be lazier. That is, if
instances obey the laws under true equality (rather than up to some equivalence
relation), then they will be essentially equivalent to these. These definitions
are incredibly cheap, so we want to use them even if it means ignoring some
non-strictly-lawful instance in an embedded type.
Foldable has far fewer laws to work with, which leaves us unwelcome
freedom in implementing it. At a minimum, we would like to ensure that
a derived foldMap is always at least as good as foldMapDefault with a
derived traverse. To accomplish that, we must define
foldMap _ _ = mempty
in these cases.
This may have different strictness properties from a standard derivation.
Consider
data NotAList a = Nil | Cons (NotAList a) deriving Foldable
The usual deriving mechanism would produce
foldMap _ Nil = mempty
foldMap f (Cons x) = foldMap f x
which is strict in the entire spine of the NotAList.
Final point: why do we even care about such types? Users will rarely if ever
map, fold, or traverse over such things themselves, but other derived
instances may:
data Hasn'tAList a = NotHere a (NotAList a) deriving Foldable
Note [EmptyDataDecls with Functor, Foldable, and Traversable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There are some slightly tricky decisions to make about how to handle
Functor, Foldable, and Traversable instances for types with no constructors.
For fmap, the two basic options are
fmap _ _ = error "Sorry, no constructors"
or
fmap _ z = case z of
In most cases, the latter is more helpful: if the thunk passed to fmap
throws an exception, we're generally going to be much more interested in
that exception than in the fact that there aren't any constructors.
In order to match the semantics for phantoms (see note above), we need to
be a bit careful about 'traverse'. The obvious definition would be
traverse _ z = case z of
but this is stricter than the one for phantoms. We instead use
traverse _ z = pure $ case z of
For foldMap, the obvious choices are
foldMap _ _ = mempty
or
foldMap _ z = case z of
We choose the first one to be consistent with what foldMapDefault does for
a derived Traversable instance.
-}
......@@ -345,7 +345,7 @@ mkBindsRep gk tycon =
-- Recurse over the sum first
from_alts, to_alts :: [Alt]
(from_alts, to_alts) = mkSum gk_ (1 :: US) tycon datacons
(from_alts,</