Add liftA2 to Applicative class
[ghc.git] / compiler / typecheck / TcGenFunctor.hs
1 {-
2 (c) The University of Glasgow 2011
3
4
5 The deriving code for the Functor, Foldable, and Traversable classes
6 (equivalent to the code in TcGenDeriv, for other classes)
7 -}
8
9 {-# LANGUAGE ScopedTypeVariables #-}
10
11 module TcGenFunctor (
12 FFoldType(..), functorLikeTraverse,
13 deepSubtypesContaining, foldDataConArgs,
14
15 gen_Functor_binds, gen_Foldable_binds, gen_Traversable_binds
16 ) where
17
18 import BasicTypes ( LexicalFixity(..) )
19 import Bag
20 import DataCon
21 import FastString
22 import HsSyn
23 import Panic
24 import PrelNames
25 import RdrName
26 import SrcLoc
27 import State
28 import TcGenDeriv
29 import TcType
30 import TyCon
31 import TyCoRep
32 import Type
33 import Util
34 import Var
35 import VarSet
36
37 import Data.Maybe (catMaybes, isJust)
38
39 {-
40 ************************************************************************
41 * *
42 Functor instances
43
44 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
45
46 * *
47 ************************************************************************
48
49 For the data type:
50
51 data T a = T1 Int a | T2 (T a)
52
53 We generate the instance:
54
55 instance Functor T where
56 fmap f (T1 b1 a) = T1 b1 (f a)
57 fmap f (T2 ta) = T2 (fmap f ta)
58
59 Notice that we don't simply apply 'fmap' to the constructor arguments.
60 Rather
61 - Do nothing to an argument whose type doesn't mention 'a'
62 - Apply 'f' to an argument of type 'a'
63 - Apply 'fmap f' to other arguments
64 That's why we have to recurse deeply into the constructor argument types,
65 rather than just one level, as we typically do.
66
67 What about types with more than one type parameter? In general, we only
68 derive Functor for the last position:
69
70 data S a b = S1 [b] | S2 (a, T a b)
71 instance Functor (S a) where
72 fmap f (S1 bs) = S1 (fmap f bs)
73 fmap f (S2 (p,q)) = S2 (a, fmap f q)
74
75 However, we have special cases for
76 - tuples
77 - functions
78
79 More formally, we write the derivation of fmap code over type variable
80 'a for type 'b as ($fmap 'a 'b). In this general notation the derived
81 instance for T is:
82
83 instance Functor T where
84 fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
85 fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1)
86
87 $(fmap 'a 'b) = \x -> x -- when b does not contain a
88 $(fmap 'a 'a) = f
89 $(fmap 'a '(b1,b2)) = \x -> case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
90 $(fmap 'a '(T b1 b2)) = fmap $(fmap 'a 'b2) -- when a only occurs in the last parameter, b2
91 $(fmap 'a '(b -> c)) = \x b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
92
93 For functions, the type parameter 'a can occur in a contravariant position,
94 which means we need to derive a function like:
95
96 cofmap :: (a -> b) -> (f b -> f a)
97
98 This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
99
100 $(cofmap 'a 'b) = \x -> x -- when b does not contain a
101 $(cofmap 'a 'a) = error "type variable in contravariant position"
102 $(cofmap 'a '(b1,b2)) = \x -> case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
103 $(cofmap 'a '[b]) = map $(cofmap 'a 'b)
104 $(cofmap 'a '(T b1 b2)) = fmap $(cofmap 'a 'b2) -- when a only occurs in the last parameter, b2
105 $(cofmap 'a '(b -> c)) = \x b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
106
107 Note that the code produced by $(fmap _ _) is always a higher order function,
108 with type `(a -> b) -> (g a -> g b)` for some g. When we need to do pattern
109 matching on the type, this means create a lambda function (see the (,) case above).
110 The resulting code for fmap can look a bit weird, for example:
111
112 data X a = X (a,Int)
113 -- generated instance
114 instance Functor X where
115 fmap f (X x) = (\y -> case y of (x1,x2) -> X (f x1, (\z -> z) x2)) x
116
117 The optimizer should be able to simplify this code by simple inlining.
118
119 An older version of the deriving code tried to avoid these applied
120 lambda functions by producing a meta level function. But the function to
121 be mapped, `f`, is a function on the code level, not on the meta level,
122 so it was eta expanded to `\x -> [| f $x |]`. This resulted in too much eta expansion.
123 It is better to produce too many lambdas than to eta expand, see ticket #7436.
124 -}
125
126 gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
127 gen_Functor_binds loc tycon
128 = (unitBag fmap_bind, emptyBag)
129 where
130 data_cons = tyConDataCons tycon
131 fun_name = L loc fmap_RDR
132 fmap_bind = mkRdrFunBind fun_name eqns
133 fun_match_ctxt = FunRhs fun_name Prefix
134
135 fmap_eqn con = evalState (match_for_con fun_match_ctxt [f_Pat] con =<< parts) bs_RDRs
136 where
137 parts = sequence $ foldDataConArgs ft_fmap con
138
139 eqns | null data_cons = [mkSimpleMatch fun_match_ctxt
140 [nlWildPat, nlWildPat]
141 (error_Expr "Void fmap")]
142 | otherwise = map fmap_eqn data_cons
143
144 ft_fmap :: FFoldType (State [RdrName] (LHsExpr RdrName))
145 ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x
146 -- fmap f = \x -> x
147 , ft_var = return f_Expr
148 -- fmap f = f
149 , ft_fun = \g h -> do
150 gg <- g
151 hh <- h
152 mkSimpleLam2 $ \x b -> return $
153 nlHsApp hh (nlHsApp x (nlHsApp gg b))
154 -- fmap f = \x b -> h (x (g b))
155 , ft_tup = \t gs -> do
156 gg <- sequence gs
157 mkSimpleLam $ mkSimpleTupleCase (match_for_con CaseAlt) t gg
158 -- fmap f = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
159 , ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g
160 -- fmap f = fmap g
161 , ft_forall = \_ g -> g
162 , ft_bad_app = panic "in other argument"
163 , ft_co_var = panic "contravariant" }
164
165 -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
166 match_for_con :: HsMatchContext RdrName
167 -> [LPat RdrName] -> DataCon -> [LHsExpr RdrName]
168 -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
169 match_for_con ctxt = mkSimpleConMatch ctxt $
170 \con_name xs -> return $ nlHsApps con_name xs -- Con x1 x2 ..
171
172 {-
173 Utility functions related to Functor deriving.
174
175 Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
176 This function works like a fold: it makes a value of type 'a' in a bottom up way.
177 -}
178
179 -- Generic traversal for Functor deriving
180 -- See Note [FFoldType and functorLikeTraverse]
181 data FFoldType a -- Describes how to fold over a Type in a functor like way
182 = FT { ft_triv :: a
183 -- ^ Does not contain variable
184 , ft_var :: a
185 -- ^ The variable itself
186 , ft_co_var :: a
187 -- ^ The variable itself, contravariantly
188 , ft_fun :: a -> a -> a
189 -- ^ Function type
190 , ft_tup :: TyCon -> [a] -> a
191 -- ^ Tuple type
192 , ft_ty_app :: Type -> a -> a
193 -- ^ Type app, variable only in last argument
194 , ft_bad_app :: a
195 -- ^ Type app, variable other than in last argument
196 , ft_forall :: TcTyVar -> a -> a
197 -- ^ Forall type
198 }
199
200 functorLikeTraverse :: forall a.
201 TyVar -- ^ Variable to look for
202 -> FFoldType a -- ^ How to fold
203 -> Type -- ^ Type to process
204 -> a
205 functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar
206 , ft_co_var = caseCoVar, ft_fun = caseFun
207 , ft_tup = caseTuple, ft_ty_app = caseTyApp
208 , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
209 ty
210 = fst (go False ty)
211 where
212 go :: Bool -- Covariant or contravariant context
213 -> Type
214 -> (a, Bool) -- (result of type a, does type contain var)
215
216 go co ty | Just ty' <- coreView ty = go co ty'
217 go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True)
218 go co (FunTy x y) | isPredTy x = go co y
219 | xc || yc = (caseFun xr yr,True)
220 where (xr,xc) = go (not co) x
221 (yr,yc) = go co y
222 go co (AppTy x y) | xc = (caseWrongArg, True)
223 | yc = (caseTyApp x yr, True)
224 where (_, xc) = go co x
225 (yr,yc) = go co y
226 go co ty@(TyConApp con args)
227 | not (or xcs) = (caseTrivial, False) -- Variable does not occur
228 -- At this point we know that xrs, xcs is not empty,
229 -- and at least one xr is True
230 | isTupleTyCon con = (caseTuple con xrs, True)
231 | or (init xcs) = (caseWrongArg, True) -- T (..var..) ty
232 | Just (fun_ty, _) <- splitAppTy_maybe ty -- T (..no var..) ty
233 = (caseTyApp fun_ty (last xrs), True)
234 | otherwise = (caseWrongArg, True) -- Non-decomposable (eg type function)
235 where
236 -- When folding over an unboxed tuple, we must explicitly drop the
237 -- runtime rep arguments, or else GHC will generate twice as many
238 -- variables in a unboxed tuple pattern match and expression as it
239 -- actually needs. See Trac #12399
240 (xrs,xcs) = unzip (map (go co) (dropRuntimeRepArgs args))
241 go co (ForAllTy (TvBndr v vis) x)
242 | isVisibleArgFlag vis = panic "unexpected visible binder"
243 | v /= var && xc = (caseForAll v xr,True)
244 where (xr,xc) = go co x
245
246 go _ _ = (caseTrivial,False)
247
248 -- Return all syntactic subterms of ty that contain var somewhere
249 -- These are the things that should appear in instance constraints
250 deepSubtypesContaining :: TyVar -> Type -> [TcType]
251 deepSubtypesContaining tv
252 = functorLikeTraverse tv
253 (FT { ft_triv = []
254 , ft_var = []
255 , ft_fun = (++)
256 , ft_tup = \_ xs -> concat xs
257 , ft_ty_app = (:)
258 , ft_bad_app = panic "in other argument"
259 , ft_co_var = panic "contravariant"
260 , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs })
261
262
263 foldDataConArgs :: FFoldType a -> DataCon -> [a]
264 -- Fold over the arguments of the datacon
265 foldDataConArgs ft con
266 = map foldArg (dataConOrigArgTys con)
267 where
268 foldArg
269 = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of
270 Just tv -> functorLikeTraverse tv ft
271 Nothing -> const (ft_triv ft)
272 -- If we are deriving Foldable for a GADT, there is a chance that the last
273 -- type variable in the data type isn't actually a type variable at all.
274 -- (for example, this can happen if the last type variable is refined to
275 -- be a concrete type such as Int). If the last type variable is refined
276 -- to be a specific type, then getTyVar_maybe will return Nothing.
277 -- See Note [DeriveFoldable with ExistentialQuantification]
278 --
279 -- The kind checks have ensured the last type parameter is of kind *.
280
281 -- Make a HsLam using a fresh variable from a State monad
282 mkSimpleLam :: (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
283 -> State [RdrName] (LHsExpr RdrName)
284 -- (mkSimpleLam fn) returns (\x. fn(x))
285 mkSimpleLam lam = do
286 (n:names) <- get
287 put names
288 body <- lam (nlHsVar n)
289 return (mkHsLam [nlVarPat n] body)
290
291 mkSimpleLam2 :: (LHsExpr RdrName -> LHsExpr RdrName
292 -> State [RdrName] (LHsExpr RdrName))
293 -> State [RdrName] (LHsExpr RdrName)
294 mkSimpleLam2 lam = do
295 (n1:n2:names) <- get
296 put names
297 body <- lam (nlHsVar n1) (nlHsVar n2)
298 return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
299
300 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
301 --
302 -- @mkSimpleConMatch fold extra_pats con insides@ produces a match clause in
303 -- which the LHS pattern-matches on @extra_pats@, followed by a match on the
304 -- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@
305 -- and its arguments, applying an expression (from @insides@) to each of the
306 -- respective arguments of @con@.
307 mkSimpleConMatch :: Monad m => HsMatchContext RdrName
308 -> (RdrName -> [LHsExpr RdrName] -> m (LHsExpr RdrName))
309 -> [LPat RdrName]
310 -> DataCon
311 -> [LHsExpr RdrName]
312 -> m (LMatch RdrName (LHsExpr RdrName))
313 mkSimpleConMatch ctxt fold extra_pats con insides = do
314 let con_name = getRdrName con
315 let vars_needed = takeList insides as_RDRs
316 let bare_pat = nlConVarPat con_name vars_needed
317 let pat = if null vars_needed
318 then bare_pat
319 else nlParPat bare_pat
320 rhs <- fold con_name (zipWith nlHsApp insides (map nlHsVar vars_needed))
321 return $ mkMatch ctxt (extra_pats ++ [pat]) rhs
322 (noLoc emptyLocalBinds)
323
324 -- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)"
325 --
326 -- @mkSimpleConMatch2 fold extra_pats con insides@ behaves very similarly to
327 -- 'mkSimpleConMatch', with two key differences:
328 --
329 -- 1. @insides@ is a @[Maybe (LHsExpr RdrName)]@ instead of a
330 -- @[LHsExpr RdrName]@. This is because it filters out the expressions
331 -- corresponding to arguments whose types do not mention the last type
332 -- variable in a derived 'Foldable' or 'Traversable' instance (i.e., the
333 -- 'Nothing' elements of @insides@).
334 --
335 -- 2. @fold@ takes an expression as its first argument instead of a
336 -- constructor name. This is because it uses a specialized
337 -- constructor function expression that only takes as many parameters as
338 -- there are argument types that mention the last type variable.
339 --
340 -- See Note [Generated code for DeriveFoldable and DeriveTraversable]
341 mkSimpleConMatch2 :: Monad m
342 => HsMatchContext RdrName
343 -> (LHsExpr RdrName -> [LHsExpr RdrName]
344 -> m (LHsExpr RdrName))
345 -> [LPat RdrName]
346 -> DataCon
347 -> [Maybe (LHsExpr RdrName)]
348 -> m (LMatch RdrName (LHsExpr RdrName))
349 mkSimpleConMatch2 ctxt fold extra_pats con insides = do
350 let con_name = getRdrName con
351 vars_needed = takeList insides as_RDRs
352 pat = nlConVarPat con_name vars_needed
353 -- Make sure to zip BEFORE invoking catMaybes. We want the variable
354 -- indicies in each expression to match up with the argument indices
355 -- in con_expr (defined below).
356 exps = catMaybes $ zipWith (\i v -> (`nlHsApp` v) <$> i)
357 insides (map nlHsVar vars_needed)
358 -- An element of argTysTyVarInfo is True if the constructor argument
359 -- with the same index has a type which mentions the last type
360 -- variable.
361 argTysTyVarInfo = map isJust insides
362 (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_RDRs
363
364 con_expr
365 | null asWithTyVar = nlHsApps con_name $ map nlHsVar asWithoutTyVar
366 | otherwise =
367 let bs = filterByList argTysTyVarInfo bs_RDRs
368 vars = filterByLists argTysTyVarInfo
369 (map nlHsVar bs_RDRs)
370 (map nlHsVar as_RDRs)
371 in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars)
372
373 rhs <- fold con_expr exps
374 return $ mkMatch ctxt (extra_pats ++ [pat]) rhs
375 (noLoc emptyLocalBinds)
376
377 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
378 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [a]
379 -> m (LMatch RdrName (LHsExpr RdrName)))
380 -> TyCon -> [a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
381 mkSimpleTupleCase match_for_con tc insides x
382 = do { let data_con = tyConSingleDataCon tc
383 ; match <- match_for_con [] data_con insides
384 ; return $ nlHsCase x [match] }
385
386 {-
387 ************************************************************************
388 * *
389 Foldable instances
390
391 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
392
393 * *
394 ************************************************************************
395
396 Deriving Foldable instances works the same way as Functor instances,
397 only Foldable instances are not possible for function types at all.
398 Given (data T a = T a a (T a) deriving Foldable), we get:
399
400 instance Foldable T where
401 foldr f z (T x1 x2 x3) =
402 $(foldr 'a 'a) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a '(T a)) x3 z ) )
403
404 -XDeriveFoldable is different from -XDeriveFunctor in that it filters out
405 arguments to the constructor that would produce useless code in a Foldable
406 instance. For example, the following datatype:
407
408 data Foo a = Foo Int a Int deriving Foldable
409
410 would have the following generated Foldable instance:
411
412 instance Foldable Foo where
413 foldr f z (Foo x1 x2 x3) = $(foldr 'a 'a) x2
414
415 since neither of the two Int arguments are folded over.
416
417 The cases are:
418
419 $(foldr 'a 'a) = f
420 $(foldr 'a '(b1,b2)) = \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
421 $(foldr 'a '(T b1 b2)) = \x z -> foldr $(foldr 'a 'b2) z x -- when a only occurs in the last parameter, b2
422
423 Note that the arguments to the real foldr function are the wrong way around,
424 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
425
426 One can envision a case for types that don't contain the last type variable:
427
428 $(foldr 'a 'b) = \x z -> z -- when b does not contain a
429
430 But this case will never materialize, since the aforementioned filtering
431 removes all such types from consideration.
432 See Note [Generated code for DeriveFoldable and DeriveTraversable].
433
434 Foldable instances differ from Functor and Traversable instances in that
435 Foldable instances can be derived for data types in which the last type
436 variable is existentially quantified. In particular, if the last type variable
437 is refined to a more specific type in a GADT:
438
439 data GADT a where
440 G :: a ~ Int => a -> G Int
441
442 then the deriving machinery does not attempt to check that the type a contains
443 Int, since it is not syntactically equal to a type variable. That is, the
444 derived Foldable instance for GADT is:
445
446 instance Foldable GADT where
447 foldr _ z (GADT _) = z
448
449 See Note [DeriveFoldable with ExistentialQuantification].
450
451 -}
452
453 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
454 gen_Foldable_binds loc tycon
455 = (listToBag [foldr_bind, foldMap_bind], emptyBag)
456 where
457 data_cons = tyConDataCons tycon
458
459 foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns
460 eqns = map foldr_eqn data_cons
461 foldr_eqn con
462 = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs
463 where
464 parts = sequence $ foldDataConArgs ft_foldr con
465
466 foldMap_bind = mkRdrFunBind (L loc foldMap_RDR) (map foldMap_eqn data_cons)
467 foldMap_eqn con
468 = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs
469 where
470 parts = sequence $ foldDataConArgs ft_foldMap con
471
472 -- Yields 'Just' an expression if we're folding over a type that mentions
473 -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
474 -- See Note [FFoldType and functorLikeTraverse]
475 ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName)))
476 ft_foldr
477 = FT { ft_triv = return Nothing
478 -- foldr f = \x z -> z
479 , ft_var = return $ Just f_Expr
480 -- foldr f = f
481 , ft_tup = \t g -> do
482 gg <- sequence g
483 lam <- mkSimpleLam2 $ \x z ->
484 mkSimpleTupleCase (match_foldr z) t gg x
485 return (Just lam)
486 -- foldr f = (\x z -> case x of ...)
487 , ft_ty_app = \_ g -> do
488 gg <- g
489 mapM (\gg' -> mkSimpleLam2 $ \x z -> return $
490 nlHsApps foldable_foldr_RDR [gg',z,x]) gg
491 -- foldr f = (\x z -> foldr g z x)
492 , ft_forall = \_ g -> g
493 , ft_co_var = panic "contravariant"
494 , ft_fun = panic "function"
495 , ft_bad_app = panic "in other argument" }
496
497 match_foldr :: LHsExpr RdrName
498 -> [LPat RdrName]
499 -> DataCon
500 -> [Maybe (LHsExpr RdrName)]
501 -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
502 match_foldr z = mkSimpleConMatch2 LambdaExpr $ \_ xs -> return (mkFoldr xs)
503 where
504 -- g1 v1 (g2 v2 (.. z))
505 mkFoldr :: [LHsExpr RdrName] -> LHsExpr RdrName
506 mkFoldr = foldr nlHsApp z
507
508 -- See Note [FFoldType and functorLikeTraverse]
509 ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName)))
510 ft_foldMap
511 = FT { ft_triv = return Nothing
512 -- foldMap f = \x -> mempty
513 , ft_var = return (Just f_Expr)
514 -- foldMap f = f
515 , ft_tup = \t g -> do
516 gg <- sequence g
517 lam <- mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg
518 return (Just lam)
519 -- foldMap f = \x -> case x of (..,)
520 , ft_ty_app = \_ g -> fmap (nlHsApp foldMap_Expr) <$> g
521 -- foldMap f = foldMap g
522 , ft_forall = \_ g -> g
523 , ft_co_var = panic "contravariant"
524 , ft_fun = panic "function"
525 , ft_bad_app = panic "in other argument" }
526
527 match_foldMap :: [LPat RdrName]
528 -> DataCon
529 -> [Maybe (LHsExpr RdrName)]
530 -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
531 match_foldMap = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkFoldMap xs)
532 where
533 -- mappend v1 (mappend v2 ..)
534 mkFoldMap :: [LHsExpr RdrName] -> LHsExpr RdrName
535 mkFoldMap [] = mempty_Expr
536 mkFoldMap xs = foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs
537
538 {-
539 ************************************************************************
540 * *
541 Traversable instances
542
543 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
544 * *
545 ************************************************************************
546
547 Again, Traversable is much like Functor and Foldable.
548
549 The cases are:
550
551 $(traverse 'a 'a) = f
552 $(traverse 'a '(b1,b2)) = \x -> case x of (x1,x2) ->
553 liftA2 (,) ($(traverse 'a 'b1) x1) ($(traverse 'a 'b2) x2)
554 $(traverse 'a '(T b1 b2)) = traverse $(traverse 'a 'b2) -- when a only occurs in the last parameter, b2
555
556 Like -XDeriveFoldable, -XDeriveTraversable filters out arguments whose types
557 do not mention the last type parameter. Therefore, the following datatype:
558
559 data Foo a = Foo Int a Int
560
561 would have the following derived Traversable instance:
562
563 instance Traversable Foo where
564 traverse f (Foo x1 x2 x3) =
565 fmap (\b2 -> Foo x1 b2 x3) ( $(traverse 'a 'a) x2 )
566
567 since the two Int arguments do not produce any effects in a traversal.
568
569 One can envision a case for types that do not mention the last type parameter:
570
571 $(traverse 'a 'b) = pure -- when b does not contain a
572
573 But this case will never materialize, since the aforementioned filtering
574 removes all such types from consideration.
575 See Note [Generated code for DeriveFoldable and DeriveTraversable].
576 -}
577
578 gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
579 gen_Traversable_binds loc tycon
580 = (unitBag traverse_bind, emptyBag)
581 where
582 data_cons = tyConDataCons tycon
583
584 traverse_bind = mkRdrFunBind (L loc traverse_RDR) eqns
585 eqns = map traverse_eqn data_cons
586 traverse_eqn con
587 = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
588 where
589 parts = sequence $ foldDataConArgs ft_trav con
590
591 -- Yields 'Just' an expression if we're folding over a type that mentions
592 -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
593 -- See Note [FFoldType and functorLikeTraverse]
594 ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName)))
595 ft_trav
596 = FT { ft_triv = return Nothing
597 -- traverse f = pure x
598 , ft_var = return (Just f_Expr)
599 -- traverse f = f x
600 , ft_tup = \t gs -> do
601 gg <- sequence gs
602 lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
603 return (Just lam)
604 -- traverse f = \x -> case x of (a1,a2,..) ->
605 -- liftA2 (,,) (g1 a1) (g2 a2) <*> ..
606 , ft_ty_app = \_ g -> fmap (nlHsApp traverse_Expr) <$> g
607 -- traverse f = traverse g
608 , ft_forall = \_ g -> g
609 , ft_co_var = panic "contravariant"
610 , ft_fun = panic "function"
611 , ft_bad_app = panic "in other argument" }
612
613 -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)
614 -- (g2 a2) <*> ...
615 match_for_con :: [LPat RdrName]
616 -> DataCon
617 -> [Maybe (LHsExpr RdrName)]
618 -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
619 match_for_con = mkSimpleConMatch2 CaseAlt $
620 \con xs -> return (mkApCon con xs)
621 where
622 -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> ..
623 mkApCon :: LHsExpr RdrName -> [LHsExpr RdrName] -> LHsExpr RdrName
624 mkApCon con [] = nlHsApps pure_RDR [con]
625 mkApCon con [x] = nlHsApps fmap_RDR [con,x]
626 mkApCon con (x1:x2:xs) =
627 foldl appAp (nlHsApps liftA2_RDR [con,x1,x2]) xs
628 where appAp x y = nlHsApps ap_RDR [x,y]
629
630 -----------------------------------------------------------------------
631
632 f_Expr, z_Expr, fmap_Expr, mempty_Expr, foldMap_Expr,
633 traverse_Expr :: LHsExpr RdrName
634 f_Expr = nlHsVar f_RDR
635 z_Expr = nlHsVar z_RDR
636 fmap_Expr = nlHsVar fmap_RDR
637 mempty_Expr = nlHsVar mempty_RDR
638 foldMap_Expr = nlHsVar foldMap_RDR
639 traverse_Expr = nlHsVar traverse_RDR
640
641 f_RDR, z_RDR :: RdrName
642 f_RDR = mkVarUnqual (fsLit "f")
643 z_RDR = mkVarUnqual (fsLit "z")
644
645 as_RDRs, bs_RDRs :: [RdrName]
646 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
647 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
648
649 f_Pat, z_Pat :: LPat RdrName
650 f_Pat = nlVarPat f_RDR
651 z_Pat = nlVarPat z_RDR
652
653 {-
654 Note [DeriveFoldable with ExistentialQuantification]
655 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
656 Functor and Traversable instances can only be derived for data types whose
657 last type parameter is truly universally polymorphic. For example:
658
659 data T a b where
660 T1 :: b -> T a b -- YES, b is unconstrained
661 T2 :: Ord b => b -> T a b -- NO, b is constrained by (Ord b)
662 T3 :: b ~ Int => b -> T a b -- NO, b is constrained by (b ~ Int)
663 T4 :: Int -> T a Int -- NO, this is just like T3
664 T5 :: Ord a => a -> b -> T a b -- YES, b is unconstrained, even
665 -- though a is existential
666 T6 :: Int -> T Int b -- YES, b is unconstrained
667
668 For Foldable instances, however, we can completely lift the constraint that
669 the last type parameter be truly universally polymorphic. This means that T
670 (as defined above) can have a derived Foldable instance:
671
672 instance Foldable (T a) where
673 foldr f z (T1 b) = f b z
674 foldr f z (T2 b) = f b z
675 foldr f z (T3 b) = f b z
676 foldr f z (T4 b) = z
677 foldr f z (T5 a b) = f b z
678 foldr f z (T6 a) = z
679
680 foldMap f (T1 b) = f b
681 foldMap f (T2 b) = f b
682 foldMap f (T3 b) = f b
683 foldMap f (T4 b) = mempty
684 foldMap f (T5 a b) = f b
685 foldMap f (T6 a) = mempty
686
687 In a Foldable instance, it is safe to fold over an occurrence of the last type
688 parameter that is not truly universally polymorphic. However, there is a bit
689 of subtlety in determining what is actually an occurrence of a type parameter.
690 T3 and T4, as defined above, provide one example:
691
692 data T a b where
693 ...
694 T3 :: b ~ Int => b -> T a b
695 T4 :: Int -> T a Int
696 ...
697
698 instance Foldable (T a) where
699 ...
700 foldr f z (T3 b) = f b z
701 foldr f z (T4 b) = z
702 ...
703 foldMap f (T3 b) = f b
704 foldMap f (T4 b) = mempty
705 ...
706
707 Notice that the argument of T3 is folded over, whereas the argument of T4 is
708 not. This is because we only fold over constructor arguments that
709 syntactically mention the universally quantified type parameter of that
710 particular data constructor. See foldDataConArgs for how this is implemented.
711
712 As another example, consider the following data type. The argument of each
713 constructor has the same type as the last type parameter:
714
715 data E a where
716 E1 :: (a ~ Int) => a -> E a
717 E2 :: Int -> E Int
718 E3 :: (a ~ Int) => a -> E Int
719 E4 :: (a ~ Int) => Int -> E a
720
721 Only E1's argument is an occurrence of a universally quantified type variable
722 that is syntactically equivalent to the last type parameter, so only E1's
723 argument will be be folded over in a derived Foldable instance.
724
725 See Trac #10447 for the original discussion on this feature. Also see
726 https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor
727 for a more in-depth explanation.
728
729 Note [FFoldType and functorLikeTraverse]
730 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
731 Deriving Functor, Foldable, and Traversable all require generating expressions
732 which perform an operation on each argument of a data constructor depending
733 on the argument's type. In particular, a generated operation can be different
734 depending on whether the type mentions the last type variable of the datatype
735 (e.g., if you have data T a = MkT a Int, then a generated foldr expression would
736 fold over the first argument of MkT, but not the second).
737
738 This pattern is abstracted with the FFoldType datatype, which provides hooks
739 for the user to specify how a constructor argument should be folded when it
740 has a type with a particular "shape". The shapes are as follows (assume that
741 a is the last type variable in a given datatype):
742
743 * ft_triv: The type does not mention the last type variable at all.
744 Examples: Int, b
745
746 * ft_var: The type is syntactically equal to the last type variable.
747 Moreover, the type appears in a covariant position (see
748 the Deriving Functor instances section of the user's guide
749 for an in-depth explanation of covariance vs. contravariance).
750 Example: a (covariantly)
751
752 * ft_co_var: The type is syntactically equal to the last type variable.
753 Moreover, the type appears in a contravariant position.
754 Example: a (contravariantly)
755
756 * ft_fun: A function type which mentions the last type variable in
757 the argument position, result position or both.
758 Examples: a -> Int, Int -> a, Maybe a -> [a]
759
760 * ft_tup: A tuple type which mentions the last type variable in at least
761 one of its fields. The TyCon argument of ft_tup represents the
762 particular tuple's type constructor.
763 Examples: (a, Int), (Maybe a, [a], Either a Int), (# Int, a #)
764
765 * ft_ty_app: A type is being applied to the last type parameter, where the
766 applied type does not mention the last type parameter (if it
767 did, it would fall under ft_bad_app). The Type argument to
768 ft_ty_app represents the applied type.
769
770 Note that functions, tuples, and foralls are distinct cases
771 and take precedence of ft_ty_app. (For example, (Int -> a) would
772 fall under (ft_fun Int a), not (ft_ty_app ((->) Int) a).
773 Examples: Maybe a, Either b a
774
775 * ft_bad_app: A type application uses the last type parameter in a position
776 other than the last argument. This case is singled out because
777 Functor, Foldable, and Traversable instances cannot be derived
778 for datatypes containing arguments with such types.
779 Examples: Either a Int, Const a b
780
781 * ft_forall: A forall'd type mentions the last type parameter on its right-
782 hand side (and is not quantified on the left-hand side). This
783 case is present mostly for plumbing purposes.
784 Example: forall b. Either b a
785
786 If FFoldType describes a strategy for folding subcomponents of a Type, then
787 functorLikeTraverse is the function that applies that strategy to the entirety
788 of a Type, returning the final folded-up result.
789
790 foldDataConArgs applies functorLikeTraverse to every argument type of a
791 constructor, returning a list of the fold results. This makes foldDataConArgs
792 a natural way to generate the subexpressions in a generated fmap, foldr,
793 foldMap, or traverse definition (the subexpressions must then be combined in
794 a method-specific fashion to form the final generated expression).
795
796 Deriving Generic1 also does validity checking by looking for the last type
797 variable in certain positions of a constructor's argument types, so it also
798 uses foldDataConArgs. See Note [degenerate use of FFoldType] in TcGenGenerics.
799
800 Note [Generated code for DeriveFoldable and DeriveTraversable]
801 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
802 We adapt the algorithms for -XDeriveFoldable and -XDeriveTraversable based on
803 that of -XDeriveFunctor. However, there an important difference between deriving
804 the former two typeclasses and the latter one, which is best illustrated by the
805 following scenario:
806
807 data WithInt a = WithInt a Int# deriving (Functor, Foldable, Traversable)
808
809 The generated code for the Functor instance is straightforward:
810
811 instance Functor WithInt where
812 fmap f (WithInt a i) = WithInt (f a) i
813
814 But if we use too similar of a strategy for deriving the Foldable and
815 Traversable instances, we end up with this code:
816
817 instance Foldable WithInt where
818 foldMap f (WithInt a i) = f a <> mempty
819
820 instance Traversable WithInt where
821 traverse f (WithInt a i) = fmap WithInt (f a) <*> pure i
822
823 This is unsatisfying for two reasons:
824
825 1. The Traversable instance doesn't typecheck! Int# is of kind #, but pure
826 expects an argument whose type is of kind *. This effectively prevents
827 Traversable from being derived for any datatype with an unlifted argument
828 type (Trac #11174).
829
830 2. The generated code contains superfluous expressions. By the Monoid laws,
831 we can reduce (f a <> mempty) to (f a), and by the Applicative laws, we can
832 reduce (fmap WithInt (f a) <*> pure i) to (fmap (\b -> WithInt b i) (f a)).
833
834 We can fix both of these issues by incorporating a slight twist to the usual
835 algorithm that we use for -XDeriveFunctor. The differences can be summarized
836 as follows:
837
838 1. In the generated expression, we only fold over arguments whose types
839 mention the last type parameter. Any other argument types will simply
840 produce useless 'mempty's or 'pure's, so they can be safely ignored.
841
842 2. In the case of -XDeriveTraversable, instead of applying ConName,
843 we apply (\b_i ... b_k -> ConName a_1 ... a_n), where
844
845 * ConName has n arguments
846 * {b_i, ..., b_k} is a subset of {a_1, ..., a_n} whose indices correspond
847 to the arguments whose types mention the last type parameter. As a
848 consequence, taking the difference of {a_1, ..., a_n} and
849 {b_i, ..., b_k} yields the all the argument values of ConName whose types
850 do not mention the last type parameter. Note that [i, ..., k] is a
851 strictly increasing—but not necessarily consecutive—integer sequence.
852
853 For example, the datatype
854
855 data Foo a = Foo Int a Int a
856
857 would generate the following Traversable instance:
858
859 instance Traversable Foo where
860 traverse f (Foo a1 a2 a3 a4) =
861 fmap (\b2 b4 -> Foo a1 b2 a3 b4) (f a2) <*> f a4
862
863 Technically, this approach would also work for -XDeriveFunctor as well, but we
864 decide not to do so because:
865
866 1. There's not much benefit to generating, e.g., ((\b -> WithInt b i) (f a))
867 instead of (WithInt (f a) i).
868
869 2. There would be certain datatypes for which the above strategy would
870 generate Functor code that would fail to typecheck. For example:
871
872 data Bar f a = Bar (forall f. Functor f => f a) deriving Functor
873
874 With the conventional algorithm, it would generate something like:
875
876 fmap f (Bar a) = Bar (fmap f a)
877
878 which typechecks. But with the strategy mentioned above, it would generate:
879
880 fmap f (Bar a) = (\b -> Bar b) (fmap f a)
881
882 which does not typecheck, since GHC cannot unify the rank-2 type variables
883 in the types of b and (fmap f a).
884 -}