never executed always true always false
1 {-
2 (c) The University of Glasgow 2011
3
4 -}
5
6
7 {-# LANGUAGE ScopedTypeVariables #-}
8 {-# LANGUAGE TypeFamilies #-}
9 {-# LANGUAGE FlexibleContexts #-}
10 {-# LANGUAGE LambdaCase #-}
11
12 -- | The deriving code for the Functor, Foldable, and Traversable classes
13 module GHC.Tc.Deriv.Functor
14 ( FFoldType(..)
15 , functorLikeTraverse
16 , deepSubtypesContaining
17 , foldDataConArgs
18
19 , gen_Functor_binds
20 , gen_Foldable_binds
21 , gen_Traversable_binds
22 )
23 where
24
25 import GHC.Prelude
26
27 import GHC.Data.Bag
28 import GHC.Core.DataCon
29 import GHC.Data.FastString
30 import GHC.Hs
31 import GHC.Utils.Panic
32 import GHC.Builtin.Names
33 import GHC.Types.Name.Reader
34 import GHC.Types.SrcLoc
35 import GHC.Utils.Monad.State.Strict
36 import GHC.Tc.Deriv.Generate
37 import GHC.Tc.Utils.TcType
38 import GHC.Core.TyCon
39 import GHC.Core.TyCo.Rep
40 import GHC.Core.Type
41 import GHC.Utils.Misc
42 import GHC.Types.Var
43 import GHC.Types.Var.Set
44 import GHC.Types.Id.Make (coerceId)
45 import GHC.Builtin.Types (true_RDR, false_RDR)
46
47 import Data.Maybe (catMaybes, isJust)
48
49 {-
50 ************************************************************************
51 * *
52 Functor instances
53
54 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
55
56 * *
57 ************************************************************************
58
59 For the data type:
60
61 data T a = T1 Int a | T2 (T a)
62
63 We generate the instance:
64
65 instance Functor T where
66 fmap f (T1 b1 a) = T1 b1 (f a)
67 fmap f (T2 ta) = T2 (fmap f ta)
68
69 Notice that we don't simply apply 'fmap' to the constructor arguments.
70 Rather
71 - Do nothing to an argument whose type doesn't mention 'a'
72 - Apply 'f' to an argument of type 'a'
73 - Apply 'fmap f' to other arguments
74 That's why we have to recurse deeply into the constructor argument types,
75 rather than just one level, as we typically do.
76
77 What about types with more than one type parameter? In general, we only
78 derive Functor for the last position:
79
80 data S a b = S1 [b] | S2 (a, T a b)
81 instance Functor (S a) where
82 fmap f (S1 bs) = S1 (fmap f bs)
83 fmap f (S2 (p,q)) = S2 (a, fmap f q)
84
85 However, we have special cases for
86 - tuples
87 - functions
88
89 More formally, we write the derivation of fmap code over type variable
90 'a for type 'b as ($fmap 'a 'b x). In this general notation the derived
91 instance for T is:
92
93 instance Functor T where
94 fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
95 fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1)
96
97 $(fmap 'a 'b x) = x -- when b does not contain a
98 $(fmap 'a 'a x) = f x
99 $(fmap 'a '(b1,b2) x) = case x of (x1,x2) -> ($(fmap 'a 'b1 x1), $(fmap 'a 'b2 x2))
100 $(fmap 'a '(T b1 a) x) = fmap f x -- when a only occurs directly as the last argument of T
101 $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2
102 $(fmap 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(fmap 'a' 'tc' (x $(cofmap 'a 'tb y)))
103
104 For functions, the type parameter 'a can occur in a contravariant position,
105 which means we need to derive a function like:
106
107 cofmap :: (a -> b) -> (f b -> f a)
108
109 This is pretty much the same as $fmap, only without the $(cofmap 'a 'a x) and
110 $(cofmap 'a '(T b1 a) x) cases:
111
112 $(cofmap 'a 'b x) = x -- when b does not contain a
113 $(cofmap 'a 'a x) = error "type variable in contravariant position"
114 $(cofmap 'a '(b1,b2) x) = case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
115 $(cofmap 'a '(T b1 a) x) = error "type variable in contravariant position" -- when a only occurs directly as the last argument of T
116 $(cofmap 'a '(T b1 b2) x) = fmap (\y. $(cofmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2
117 $(cofmap 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(cofmap 'a' 'tc' (x $(fmap 'a 'tb y)))
118
119 Note that the code produced by $(fmap _ _ _) is always a higher order function,
120 with type `(a -> b) -> (g a -> g b)` for some g.
121
122 Note that there are two distinct cases in $fmap (and $cofmap) that match on an
123 application of some type constructor T (where T is not a tuple type
124 constructor):
125
126 $(fmap 'a '(T b1 a) x) = fmap f x -- when a only occurs directly as the last argument of T
127 $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2
128
129 While the latter case technically subsumes the former case, it is important to
130 give special treatment to the former case to avoid unnecessary eta expansion.
131 See Note [Avoid unnecessary eta expansion in derived fmap implementations].
132
133 We also generate code for (<$) in addition to fmap—see Note [Deriving <$] for
134 an explanation of why this is important. Just like $fmap/$cofmap above, there
135 is a similar algorithm for generating `p <$ x` (for some constant `p`):
136
137 $(replace 'a 'b x) = x -- when b does not contain a
138 $(replace 'a 'a x) = p
139 $(replace 'a '(b1,b2) x) = case x of (x1,x2) -> ($(replace 'a 'b1 x1), $(replace 'a 'b2 x2))
140 $(replace 'a '(T b1 a) x) = p <$ x -- when a only occurs directly as the last argument of T
141 $(replace 'a '(T b1 b2) x) = fmap (\y. $(replace 'a 'b2 y)) x -- when a only occurs in the last parameter, b2
142 $(replace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(replace 'a' 'tc' (x $(coreplace 'a 'tb y)))
143
144 $(coreplace 'a 'b x) = x -- when b does not contain a
145 $(coreplace 'a 'a x) = error "type variable in contravariant position"
146 $(coreplace 'a '(b1,b2) x) = case x of (x1,x2) -> ($(coreplace 'a 'b1 x1), $(coreplace 'a 'b2 x2))
147 $(coreplace 'a '(T b1 a) x) = error "type variable in contravariant position" -- when a only occurs directly as the last argument of T
148 $(coreplace 'a '(T b1 b2) x) = fmap (\y. $(coreplace 'a 'b2 y)) x -- when a only occurs in the last parameter, b2
149 $(coreplace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(coreplace 'a' 'tc' (x $(replace 'a 'tb y)))
150 -}
151
152 gen_Functor_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
153 -- When the argument is phantom, we can use fmap _ = coerce
154 -- See Note [Phantom types with Functor, Foldable, and Traversable]
155 gen_Functor_binds loc tycon _
156 | Phantom <- last (tyConRoles tycon)
157 = (unitBag fmap_bind, emptyBag)
158 where
159 fmap_name = L (noAnnSrcSpan loc) fmap_RDR
160 fmap_bind = mkRdrFunBind fmap_name fmap_eqns
161 fmap_eqns = [mkSimpleMatch fmap_match_ctxt
162 [nlWildPat]
163 coerce_Expr]
164 fmap_match_ctxt = mkPrefixFunRhs fmap_name
165
166 gen_Functor_binds loc tycon tycon_args
167 = (listToBag [fmap_bind, replace_bind], emptyBag)
168 where
169 data_cons = getPossibleDataCons tycon tycon_args
170 fmap_name = L (noAnnSrcSpan loc) fmap_RDR
171
172 -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
173 fmap_bind = mkRdrFunBindEC 2 id fmap_name fmap_eqns
174 fmap_match_ctxt = mkPrefixFunRhs fmap_name
175
176 fmap_eqn con = flip evalState bs_RDRs $
177 match_for_con fmap_match_ctxt [f_Pat] con parts
178 where
179 parts = foldDataConArgs ft_fmap con
180
181 fmap_eqns = map fmap_eqn data_cons
182
183 ft_fmap :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
184 ft_fmap = FT { ft_triv = \x -> pure x
185 -- fmap f x = x
186 , ft_var = \x -> pure $ nlHsApp f_Expr x
187 -- fmap f x = f x
188 , ft_fun = \g h x -> mkSimpleLam $ \b -> do
189 gg <- g b
190 h $ nlHsApp x gg
191 -- fmap f x = \b -> h (x (g b))
192 , ft_tup = mkSimpleTupleCase (match_for_con CaseAlt)
193 -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
194 , ft_ty_app = \_ arg_ty g x ->
195 -- If the argument type is a bare occurrence of the
196 -- data type's last type variable, then we can generate
197 -- more efficient code.
198 -- See Note [Avoid unnecessary eta expansion in derived fmap implementations]
199 if tcIsTyVarTy arg_ty
200 then pure $ nlHsApps fmap_RDR [f_Expr,x]
201 else do gg <- mkSimpleLam g
202 pure $ nlHsApps fmap_RDR [gg,x]
203 -- fmap f x = fmap g x
204 , ft_forall = \_ g x -> g x
205 , ft_bad_app = panic "in other argument in ft_fmap"
206 , ft_co_var = panic "contravariant in ft_fmap" }
207
208 -- See Note [Deriving <$]
209 replace_name = L (noAnnSrcSpan loc) replace_RDR
210
211 -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
212 replace_bind = mkRdrFunBindEC 2 id replace_name replace_eqns
213 replace_match_ctxt = mkPrefixFunRhs replace_name
214
215 replace_eqn con = flip evalState bs_RDRs $
216 match_for_con replace_match_ctxt [z_Pat] con parts
217 where
218 parts = foldDataConArgs ft_replace con
219
220 replace_eqns = map replace_eqn data_cons
221
222 ft_replace :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
223 ft_replace = FT { ft_triv = \x -> pure x
224 -- p <$ x = x
225 , ft_var = \_ -> pure z_Expr
226 -- p <$ _ = p
227 , ft_fun = \g h x -> mkSimpleLam $ \b -> do
228 gg <- g b
229 h $ nlHsApp x gg
230 -- p <$ x = \b -> h (x (g b))
231 , ft_tup = mkSimpleTupleCase (match_for_con CaseAlt)
232 -- p <$ x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
233 , ft_ty_app = \_ arg_ty g x ->
234 -- If the argument type is a bare occurrence of the
235 -- data type's last type variable, then we can generate
236 -- more efficient code.
237 -- See [Deriving <$]
238 if tcIsTyVarTy arg_ty
239 then pure $ nlHsApps replace_RDR [z_Expr,x]
240 else do gg <- mkSimpleLam g
241 pure $ nlHsApps fmap_RDR [gg,x]
242 -- p <$ x = fmap (p <$) x
243 , ft_forall = \_ g x -> g x
244 , ft_bad_app = panic "in other argument in ft_replace"
245 , ft_co_var = panic "contravariant in ft_replace" }
246
247 -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
248 match_for_con :: Monad m
249 => HsMatchContext GhcPs
250 -> [LPat GhcPs] -> DataCon
251 -> [LHsExpr GhcPs -> m (LHsExpr GhcPs)]
252 -> m (LMatch GhcPs (LHsExpr GhcPs))
253 match_for_con ctxt = mkSimpleConMatch ctxt $
254 \con_name xsM -> do xs <- sequence xsM
255 pure $ nlHsApps con_name xs -- Con x1 x2 ..
256
257 {-
258 Note [Avoid unnecessary eta expansion in derived fmap implementations]
259 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
260 For the sake of simplicity, the algorithm that derived implementations of
261 fmap used to have a single case that dealt with applications of some type
262 constructor T (where T is not a tuple type constructor):
263
264 $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2
265
266 This generated less than optimal code in certain situations, however. Consider
267 this example:
268
269 data List a = Nil | Cons a (List a) deriving Functor
270
271 This would generate the following Functor instance:
272
273 instance Functor List where
274 fmap f Nil = Nil
275 fmap f (Cons x xs) = Cons (f x) (fmap (\y -> f y) xs)
276
277 The code `fmap (\y -> f y) xs` is peculiar, since it eta expands an application
278 of `f`. What's worse, this eta expansion actually degrades performance! To see
279 why, we can trace an invocation of fmap on a small List:
280
281 fmap id $ Cons 0 $ Cons 0 $ Cons 0 $ Cons 0 Nil
282
283 Cons (id 0) $ fmap (\y -> id y)
284 $ Cons 0 $ Cons 0 $ Cons 0 Nil
285
286 Cons (id 0) $ Cons ((\y -> id y) 0)
287 $ fmap (\y' -> (\y -> id y) y')
288 $ Cons 0 $ Cons 0 Nil
289
290 Cons (id 0) $ Cons ((\y -> id y) 0)
291 $ Cons ((\y' -> (\y -> id y) y') 0)
292 $ fmap (\y'' -> (\y' -> (\y -> id y) y') y'')
293 $ Cons 0 Nil
294
295 Cons (id 0) $ Cons ((\y -> id y) 0)
296 $ Cons ((\y' -> (\y -> id y) y') 0)
297 $ Cons ((\y'' -> (\y' -> (\y -> id y) y') y'') 0)
298 $ fmap (\y''' -> (\y'' -> (\y' -> (\y -> id y) y') y'') y''')
299 $ Nil
300
301 Cons (id 0) $ Cons ((\y -> id y) 0)
302 $ Cons ((\y' -> (\y -> id y) y') 0)
303 $ Cons ((\y'' -> (\y' -> (\y -> id y) y') y'') 0)
304 $ Nil
305
306 Notice how the number of lambdas—and hence, the number of closures—one
307 needs to evaluate grows very quickly. In general, a List with N cons cells will
308 require (1 + 2 + ... (N-1)) beta reductions, which takes O(N^2) time! This is
309 what caused the performance issues observed in #7436.
310
311 But hold on a second: shouldn't GHC's optimizer be able to eta reduce
312 `\y -> f y` to `f` and avoid these beta reductions? Unfortunately, this is not
313 the case. In general, eta reduction can change the semantics of a program. For
314 instance, (\x -> ⊥) `seq` () converges, but ⊥ `seq` () diverges. It just so
315 happens that the fmap implementation above would have the same semantics
316 regardless of whether or not `\y -> f y` or `f` is used, but GHC's optimizer is
317 not yet smart enough to realize this (see #17881).
318
319 To avoid this quadratic blowup, we add a special case to $fmap that applies
320 `fmap f` directly:
321
322 $(fmap 'a '(T b1 a) x) = fmap f x -- when a only occurs directly as the last argument of T
323 $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2
324
325 With this modified algorithm, the derived Functor List instance becomes:
326
327 instance Functor List where
328 fmap f Nil = Nil
329 fmap f (Cons x xs) = Cons (f x) (fmap f xs)
330
331 No lambdas in sight, just the way we like it.
332
333 This special case does not prevent all sources quadratic closure buildup,
334 however. In this example:
335
336 data PolyList a = PLNil | PLCons a (PolyList (PolyList a))
337 deriving Functor
338
339 We would derive the following code:
340
341 instance Functor PolyList where
342 fmap f PLNil = PLNil
343 fmap f (PLCons x xs) = PLCons (f x) (fmap (\y -> fmap f y) xs)
344
345 The use of `fmap (\y -> fmap f y) xs` builds up closures in much the same way
346 as `fmap (\y -> f y) xs`. The difference here is that even if we eta reduced
347 to `fmap (fmap f) xs`, GHC would /still/ build up a closure, since we are
348 recursively invoking fmap with a different argument (fmap f). Since we end up
349 paying the price of building a closure either way, we do not extend the special
350 case in $fmap any further, since it wouldn't buy us anything.
351
352 The ft_ty_app field of FFoldType distinguishes between these two $fmap cases by
353 inspecting the argument type. If the argument type is a bare type variable,
354 then we can conclude the type variable /must/ be the same as the data type's
355 last type parameter. We know that this must be the case since there is an
356 invariant that the argument type in ft_ty_app will always contain the last
357 type parameter somewhere (see Note [FFoldType and functorLikeTraverse]), so
358 if the argument type is a bare variable, then that must be exactly the last
359 type parameter.
360
361 Note that the ft_ty_app case of ft_replace (which derives implementations of
362 (<$)) also inspects the argument type to generate more efficient code.
363 See Note [Deriving <$].
364
365 Note [Deriving <$]
366 ~~~~~~~~~~~~~~~~~~
367
368 We derive the definition of <$. Allowing this to take the default definition
369 can lead to memory leaks: mapping over a structure with a constant function can
370 fill the result structure with trivial thunks that retain the values from the
371 original structure. The simplifier seems to handle this all right for simple
372 types, but not for recursive ones. Consider
373
374 data Tree a = Bin !(Tree a) a !(Tree a) | Tip deriving Functor
375
376 -- fmap _ Tip = Tip
377 -- fmap f (Bin l v r) = Bin (fmap f l) (f v) (fmap f r)
378
379 Using the default definition of <$, we get (<$) x = fmap (\_ -> x) and that
380 simplifies no further. Why is that? `fmap` is defined recursively, so GHC
381 cannot inline it. The static argument transformation would turn the definition
382 into a non-recursive one
383
384 -- fmap f = go where
385 -- go Tip = Tip
386 -- go (Bin l v r) = Bin (go l) (f v) (go r)
387
388 which GHC could inline, producing an efficient definion of `<$`. But there are
389 several problems. First, GHC does not perform the static argument transformation
390 by default, even with -O2. Second, even when it does perform the static argument
391 transformation, it does so only when there are at least two static arguments,
392 which is not the case for fmap. Finally, when the type in question is
393 non-regular, such as
394
395 data Nesty a = Z a | S (Nesty a) (Nest (a, a))
396
397 the function argument is no longer (entirely) static, so the static argument
398 transformation will do nothing for us.
399
400 Applying the default definition of `<$` will produce a tree full of thunks that
401 look like ((\_ -> x) x0), which represents unnecessary thunk allocation and
402 also retention of the previous value, potentially leaking memory. Instead, we
403 derive <$ separately. Two aspects are different from fmap: the case of the
404 sought type variable (ft_var) and the case of a type application (ft_ty_app).
405 The interesting one is ft_ty_app. We have to distinguish two cases: the
406 "immediate" case where the type argument *is* the sought type variable, and
407 the "nested" case where the type argument *contains* the sought type variable.
408
409 The immediate case:
410
411 Suppose we have
412
413 data Imm a = Imm (F ... a)
414
415 Then we want to define
416
417 x <$ Imm q = Imm (x <$ q)
418
419 The nested case:
420
421 Suppose we have
422
423 data Nes a = Nes (F ... (G a))
424
425 Then we want to define
426
427 x <$ Nes q = Nes (fmap (x <$) q)
428
429 We inspect the argument type in ft_ty_app
430 (see Note [FFoldType and functorLikeTraverse]) to distinguish between these
431 two cases. If the argument type is a bare type variable, then we know that it
432 must be the same variable as the data type's last type parameter.
433 This is very similar to a trick that derived fmap implementations
434 use in their own ft_ty_app case.
435 See Note [Avoid unnecessary eta expansion in derived fmap implementations],
436 which explains why checking if the argument type is a bare variable is
437 the right thing to do.
438
439 We could, but do not, give tuples special treatment to improve efficiency
440 in some cases. Suppose we have
441
442 data Nest a = Z a | S (Nest (a,a))
443
444 The optimal definition would be
445
446 x <$ Z _ = Z x
447 x <$ S t = S ((x, x) <$ t)
448
449 which produces a result with maximal internal sharing. The reason we do not
450 attempt to treat this case specially is that we have no way to give
451 user-provided tuple-like types similar treatment. If the user changed the
452 definition to
453
454 data Pair a = Pair a a
455 data Nest a = Z a | S (Nest (Pair a))
456
457 they would experience a surprising degradation in performance. -}
458
459
460 {-
461 Utility functions related to Functor deriving.
462
463 Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
464 This function works like a fold: it makes a value of type 'a' in a bottom up way.
465 -}
466
467 -- Generic traversal for Functor deriving
468 -- See Note [FFoldType and functorLikeTraverse]
469 data FFoldType a -- Describes how to fold over a Type in a functor like way
470 = FT { ft_triv :: a
471 -- ^ Does not contain variable
472 , ft_var :: a
473 -- ^ The variable itself
474 , ft_co_var :: a
475 -- ^ The variable itself, contravariantly
476 , ft_fun :: a -> a -> a
477 -- ^ Function type
478 , ft_tup :: TyCon -> [a] -> a
479 -- ^ Tuple type. The @[a]@ is the result of folding over the
480 -- arguments of the tuple.
481 , ft_ty_app :: Type -> Type -> a -> a
482 -- ^ Type app, variable only in last argument. The two 'Type's are
483 -- the function and argument parts of @fun_ty arg_ty@,
484 -- respectively.
485 , ft_bad_app :: a
486 -- ^ Type app, variable other than in last argument
487 , ft_forall :: TcTyVar -> a -> a
488 -- ^ Forall type
489 }
490
491 functorLikeTraverse :: forall a.
492 TyVar -- ^ Variable to look for
493 -> FFoldType a -- ^ How to fold
494 -> Type -- ^ Type to process
495 -> a
496 functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar
497 , ft_co_var = caseCoVar, ft_fun = caseFun
498 , ft_tup = caseTuple, ft_ty_app = caseTyApp
499 , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
500 ty
501 = fst (go False ty)
502 where
503 go :: Bool -- Covariant or contravariant context
504 -> Type
505 -> (a, Bool) -- (result of type a, does type contain var)
506
507 go co ty | Just ty' <- tcView ty = go co ty'
508 go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True)
509 go co (FunTy { ft_arg = x, ft_res = y, ft_af = af })
510 | InvisArg <- af = go co y
511 | xc || yc = (caseFun xr yr,True)
512 where (xr,xc) = go (not co) x
513 (yr,yc) = go co y
514 go co (AppTy x y) | xc = (caseWrongArg, True)
515 | yc = (caseTyApp x y yr, True)
516 where (_, xc) = go co x
517 (yr,yc) = go co y
518 go co ty@(TyConApp con args)
519 | not (or xcs) = (caseTrivial, False) -- Variable does not occur
520 -- At this point we know that xrs, xcs is not empty,
521 -- and at least one xr is True
522 | isTupleTyCon con = (caseTuple con xrs, True)
523 | or (init xcs) = (caseWrongArg, True) -- T (..var..) ty
524 | Just (fun_ty, arg_ty) <- splitAppTy_maybe ty -- T (..no var..) ty
525 = (caseTyApp fun_ty arg_ty (last xrs), True)
526 | otherwise = (caseWrongArg, True) -- Non-decomposable (eg type function)
527 where
528 -- When folding over an unboxed tuple, we must explicitly drop the
529 -- runtime rep arguments, or else GHC will generate twice as many
530 -- variables in a unboxed tuple pattern match and expression as it
531 -- actually needs. See #12399
532 (xrs,xcs) = unzip (map (go co) (dropRuntimeRepArgs args))
533 go co (ForAllTy (Bndr v vis) x)
534 | isVisibleArgFlag vis = panic "unexpected visible binder"
535 | v /= var && xc = (caseForAll v xr,True)
536 where (xr,xc) = go co x
537
538 go _ _ = (caseTrivial,False)
539
540 -- Return all syntactic subterms of ty that contain var somewhere
541 -- These are the things that should appear in instance constraints
542 deepSubtypesContaining :: TyVar -> Type -> [TcType]
543 deepSubtypesContaining tv
544 = functorLikeTraverse tv
545 (FT { ft_triv = []
546 , ft_var = []
547 , ft_fun = (++)
548 , ft_tup = \_ xs -> concat xs
549 , ft_ty_app = \t _ ts -> t:ts
550 , ft_bad_app = panic "in other argument in deepSubtypesContaining"
551 , ft_co_var = panic "contravariant in deepSubtypesContaining"
552 , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs })
553
554
555 foldDataConArgs :: FFoldType a -> DataCon -> [a]
556 -- Fold over the arguments of the datacon
557 foldDataConArgs ft con
558 = map foldArg (map scaledThing $ dataConOrigArgTys con)
559 where
560 foldArg
561 = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of
562 Just tv -> functorLikeTraverse tv ft
563 Nothing -> const (ft_triv ft)
564 -- If we are deriving Foldable for a GADT, there is a chance that the last
565 -- type variable in the data type isn't actually a type variable at all.
566 -- (for example, this can happen if the last type variable is refined to
567 -- be a concrete type such as Int). If the last type variable is refined
568 -- to be a specific type, then getTyVar_maybe will return Nothing.
569 -- See Note [DeriveFoldable with ExistentialQuantification]
570 --
571 -- The kind checks have ensured the last type parameter is of kind *.
572
573 -- Make a HsLam using a fresh variable from a State monad
574 mkSimpleLam :: (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
575 -> State [RdrName] (LHsExpr GhcPs)
576 -- (mkSimpleLam fn) returns (\x. fn(x))
577 mkSimpleLam lam =
578 get >>= \case
579 n:names -> do
580 put names
581 body <- lam (nlHsVar n)
582 return (mkHsLam [nlVarPat n] body)
583 _ -> panic "mkSimpleLam"
584
585 mkSimpleLam2 :: (LHsExpr GhcPs -> LHsExpr GhcPs
586 -> State [RdrName] (LHsExpr GhcPs))
587 -> State [RdrName] (LHsExpr GhcPs)
588 mkSimpleLam2 lam =
589 get >>= \case
590 n1:n2:names -> do
591 put names
592 body <- lam (nlHsVar n1) (nlHsVar n2)
593 return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
594 _ -> panic "mkSimpleLam2"
595
596 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
597 --
598 -- @mkSimpleConMatch fold extra_pats con insides@ produces a match clause in
599 -- which the LHS pattern-matches on @extra_pats@, followed by a match on the
600 -- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@
601 -- and its arguments, applying an expression (from @insides@) to each of the
602 -- respective arguments of @con@.
603 mkSimpleConMatch :: Monad m => HsMatchContext GhcPs
604 -> (RdrName -> [a] -> m (LHsExpr GhcPs))
605 -> [LPat GhcPs]
606 -> DataCon
607 -> [LHsExpr GhcPs -> a]
608 -> m (LMatch GhcPs (LHsExpr GhcPs))
609 mkSimpleConMatch ctxt fold extra_pats con insides = do
610 let con_name = getRdrName con
611 let vars_needed = takeList insides as_RDRs
612 let bare_pat = nlConVarPat con_name vars_needed
613 let pat = if null vars_needed
614 then bare_pat
615 else nlParPat bare_pat
616 rhs <- fold con_name
617 (zipWith (\i v -> i $ nlHsVar v) insides vars_needed)
618 return $ mkMatch ctxt (extra_pats ++ [pat]) rhs emptyLocalBinds
619
620 -- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)"
621 --
622 -- @mkSimpleConMatch2 fold extra_pats con insides@ behaves very similarly to
623 -- 'mkSimpleConMatch', with two key differences:
624 --
625 -- 1. @insides@ is a @[Maybe (LHsExpr RdrName)]@ instead of a
626 -- @[LHsExpr RdrName]@. This is because it filters out the expressions
627 -- corresponding to arguments whose types do not mention the last type
628 -- variable in a derived 'Foldable' or 'Traversable' instance (i.e., the
629 -- 'Nothing' elements of @insides@).
630 --
631 -- 2. @fold@ takes an expression as its first argument instead of a
632 -- constructor name. This is because it uses a specialized
633 -- constructor function expression that only takes as many parameters as
634 -- there are argument types that mention the last type variable.
635 --
636 -- See Note [Generated code for DeriveFoldable and DeriveTraversable]
637 mkSimpleConMatch2 :: Monad m
638 => HsMatchContext GhcPs
639 -> (LHsExpr GhcPs -> [LHsExpr GhcPs]
640 -> m (LHsExpr GhcPs))
641 -> [LPat GhcPs]
642 -> DataCon
643 -> [Maybe (LHsExpr GhcPs)]
644 -> m (LMatch GhcPs (LHsExpr GhcPs))
645 mkSimpleConMatch2 ctxt fold extra_pats con insides = do
646 let con_name = getRdrName con
647 vars_needed = takeList insides as_RDRs
648 pat = nlConVarPat con_name vars_needed
649 -- Make sure to zip BEFORE invoking catMaybes. We want the variable
650 -- indices in each expression to match up with the argument indices
651 -- in con_expr (defined below).
652 exps = catMaybes $ zipWith (\i v -> (`nlHsApp` nlHsVar v) <$> i)
653 insides vars_needed
654 -- An element of argTysTyVarInfo is True if the constructor argument
655 -- with the same index has a type which mentions the last type
656 -- variable.
657 argTysTyVarInfo = map isJust insides
658 (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_Vars
659
660 con_expr
661 | null asWithTyVar = nlHsApps con_name asWithoutTyVar
662 | otherwise =
663 let bs = filterByList argTysTyVarInfo bs_RDRs
664 vars = filterByLists argTysTyVarInfo bs_Vars as_Vars
665 in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars)
666
667 rhs <- fold con_expr exps
668 return $ mkMatch ctxt (extra_pats ++ [pat]) rhs emptyLocalBinds
669
670 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
671 mkSimpleTupleCase :: Monad m => ([LPat GhcPs] -> DataCon -> [a]
672 -> m (LMatch GhcPs (LHsExpr GhcPs)))
673 -> TyCon -> [a] -> LHsExpr GhcPs -> m (LHsExpr GhcPs)
674 mkSimpleTupleCase match_for_con tc insides x
675 = do { let data_con = tyConSingleDataCon tc
676 ; match <- match_for_con [] data_con insides
677 ; return $ nlHsCase x [match] }
678
679 {-
680 ************************************************************************
681 * *
682 Foldable instances
683
684 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
685
686 * *
687 ************************************************************************
688
689 Deriving Foldable instances works the same way as Functor instances,
690 only Foldable instances are not possible for function types at all.
691 Given (data T a = T a a (T a) deriving Foldable), we get:
692
693 instance Foldable T where
694 foldr f z (T x1 x2 x3) =
695 $(foldr 'a 'a) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a '(T a)) x3 z ) )
696
697 -XDeriveFoldable is different from -XDeriveFunctor in that it filters out
698 arguments to the constructor that would produce useless code in a Foldable
699 instance. For example, the following datatype:
700
701 data Foo a = Foo Int a Int deriving Foldable
702
703 would have the following generated Foldable instance:
704
705 instance Foldable Foo where
706 foldr f z (Foo x1 x2 x3) = $(foldr 'a 'a) x2
707
708 since neither of the two Int arguments are folded over.
709
710 The cases are:
711
712 $(foldr 'a 'a) = f
713 $(foldr 'a '(b1,b2)) = \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
714 $(foldr 'a '(T b1 b2)) = \x z -> foldr $(foldr 'a 'b2) z x -- when a only occurs in the last parameter, b2
715
716 Note that the arguments to the real foldr function are the wrong way around,
717 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
718
719 One can envision a case for types that don't contain the last type variable:
720
721 $(foldr 'a 'b) = \x z -> z -- when b does not contain a
722
723 But this case will never materialize, since the aforementioned filtering
724 removes all such types from consideration.
725 See Note [Generated code for DeriveFoldable and DeriveTraversable].
726
727 Foldable instances differ from Functor and Traversable instances in that
728 Foldable instances can be derived for data types in which the last type
729 variable is existentially quantified. In particular, if the last type variable
730 is refined to a more specific type in a GADT:
731
732 data GADT a where
733 G :: a ~ Int => a -> G Int
734
735 then the deriving machinery does not attempt to check that the type a contains
736 Int, since it is not syntactically equal to a type variable. That is, the
737 derived Foldable instance for GADT is:
738
739 instance Foldable GADT where
740 foldr _ z (GADT _) = z
741
742 See Note [DeriveFoldable with ExistentialQuantification].
743
744 Note [Deriving null]
745 ~~~~~~~~~~~~~~~~~~~~
746
747 In some cases, deriving the definition of 'null' can produce much better
748 results than the default definition. For example, with
749
750 data SnocList a = Nil | Snoc (SnocList a) a
751
752 the default definition of 'null' would walk the entire spine of a
753 nonempty snoc-list before concluding that it is not null. But looking at
754 the Snoc constructor, we can immediately see that it contains an 'a', and
755 so 'null' can return False immediately if it matches on Snoc. When we
756 derive 'null', we keep track of things that cannot be null. The interesting
757 case is type application. Given
758
759 data Wrap a = Wrap (Foo (Bar a))
760
761 we use
762
763 null (Wrap fba) = all null fba
764
765 but if we see
766
767 data Wrap a = Wrap (Foo a)
768
769 we can just use
770
771 null (Wrap fa) = null fa
772
773 Indeed, we allow this to happen even for tuples:
774
775 data Wrap a = Wrap (Foo (a, Int))
776
777 produces
778
779 null (Wrap fa) = null fa
780
781 As explained in Note [Deriving <$], giving tuples special performance treatment
782 could surprise users if they switch to other types, but Ryan Scott seems to
783 think it's okay to do it for now.
784 -}
785
786 gen_Foldable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
787 -- When the parameter is phantom, we can use foldMap _ _ = mempty
788 -- See Note [Phantom types with Functor, Foldable, and Traversable]
789 gen_Foldable_binds loc tycon _
790 | Phantom <- last (tyConRoles tycon)
791 = (unitBag foldMap_bind, emptyBag)
792 where
793 foldMap_name = L (noAnnSrcSpan loc) foldMap_RDR
794 foldMap_bind = mkRdrFunBind foldMap_name foldMap_eqns
795 foldMap_eqns = [mkSimpleMatch foldMap_match_ctxt
796 [nlWildPat, nlWildPat]
797 mempty_Expr]
798 foldMap_match_ctxt = mkPrefixFunRhs foldMap_name
799
800 gen_Foldable_binds loc tycon tycon_args
801 | null data_cons -- There's no real point producing anything but
802 -- foldMap for a type with no constructors.
803 = (unitBag foldMap_bind, emptyBag)
804
805 | otherwise
806 = (listToBag [foldr_bind, foldMap_bind, null_bind], emptyBag)
807 where
808 data_cons = getPossibleDataCons tycon tycon_args
809
810 foldr_name = L (noAnnSrcSpan loc) foldable_foldr_RDR
811
812 foldr_bind = mkRdrFunBind (L (noAnnSrcSpan loc) foldable_foldr_RDR) eqns
813 eqns = map foldr_eqn data_cons
814 foldr_eqn con
815 = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs
816 where
817 parts = sequence $ foldDataConArgs ft_foldr con
818 foldr_match_ctxt = mkPrefixFunRhs foldr_name
819
820 foldMap_name = L (noAnnSrcSpan loc) foldMap_RDR
821
822 -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
823 foldMap_bind = mkRdrFunBindEC 2 (const mempty_Expr)
824 foldMap_name foldMap_eqns
825
826 foldMap_eqns = map foldMap_eqn data_cons
827
828 foldMap_eqn con
829 = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs
830 where
831 parts = sequence $ foldDataConArgs ft_foldMap con
832 foldMap_match_ctxt = mkPrefixFunRhs foldMap_name
833
834 -- Given a list of NullM results, produce Nothing if any of
835 -- them is NotNull, and otherwise produce a list of Maybes
836 -- with Justs representing unknowns and Nothings representing
837 -- things that are definitely null.
838 convert :: [NullM a] -> Maybe [Maybe a]
839 convert = traverse go where
840 go IsNull = Just Nothing
841 go NotNull = Nothing
842 go (NullM a) = Just (Just a)
843
844 null_name = L (noAnnSrcSpan loc) null_RDR
845 null_match_ctxt = mkPrefixFunRhs null_name
846 null_bind = mkRdrFunBind null_name null_eqns
847 null_eqns = map null_eqn data_cons
848 null_eqn con
849 = flip evalState bs_RDRs $ do
850 parts <- sequence $ foldDataConArgs ft_null con
851 case convert parts of
852 Nothing -> return $
853 mkMatch null_match_ctxt [nlParPat (nlWildConPat con)]
854 false_Expr emptyLocalBinds
855 Just cp -> match_null [] con cp
856
857 -- Yields 'Just' an expression if we're folding over a type that mentions
858 -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
859 -- See Note [FFoldType and functorLikeTraverse]
860 ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
861 ft_foldr
862 = FT { ft_triv = return Nothing
863 -- foldr f = \x z -> z
864 , ft_var = return $ Just f_Expr
865 -- foldr f = f
866 , ft_tup = \t g -> do
867 gg <- sequence g
868 lam <- mkSimpleLam2 $ \x z ->
869 mkSimpleTupleCase (match_foldr z) t gg x
870 return (Just lam)
871 -- foldr f = (\x z -> case x of ...)
872 , ft_ty_app = \_ _ g -> do
873 gg <- g
874 mapM (\gg' -> mkSimpleLam2 $ \x z -> return $
875 nlHsApps foldable_foldr_RDR [gg',z,x]) gg
876 -- foldr f = (\x z -> foldr g z x)
877 , ft_forall = \_ g -> g
878 , ft_co_var = panic "contravariant in ft_foldr"
879 , ft_fun = panic "function in ft_foldr"
880 , ft_bad_app = panic "in other argument in ft_foldr" }
881
882 match_foldr :: Monad m
883 => LHsExpr GhcPs
884 -> [LPat GhcPs]
885 -> DataCon
886 -> [Maybe (LHsExpr GhcPs)]
887 -> m (LMatch GhcPs (LHsExpr GhcPs))
888 match_foldr z = mkSimpleConMatch2 foldr_match_ctxt $ \_ xs -> return (mkFoldr xs)
889 where
890 -- g1 v1 (g2 v2 (.. z))
891 mkFoldr :: [LHsExpr GhcPs] -> LHsExpr GhcPs
892 mkFoldr = foldr nlHsApp z
893
894 -- See Note [FFoldType and functorLikeTraverse]
895 ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
896 ft_foldMap
897 = FT { ft_triv = return Nothing
898 -- foldMap f = \x -> mempty
899 , ft_var = return (Just f_Expr)
900 -- foldMap f = f
901 , ft_tup = \t g -> do
902 gg <- sequence g
903 lam <- mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg
904 return (Just lam)
905 -- foldMap f = \x -> case x of (..,)
906 , ft_ty_app = \_ _ g -> fmap (nlHsApp foldMap_Expr) <$> g
907 -- foldMap f = foldMap g
908 , ft_forall = \_ g -> g
909 , ft_co_var = panic "contravariant in ft_foldMap"
910 , ft_fun = panic "function in ft_foldMap"
911 , ft_bad_app = panic "in other argument in ft_foldMap" }
912
913 match_foldMap :: Monad m
914 => [LPat GhcPs]
915 -> DataCon
916 -> [Maybe (LHsExpr GhcPs)]
917 -> m (LMatch GhcPs (LHsExpr GhcPs))
918 match_foldMap = mkSimpleConMatch2 foldMap_match_ctxt $ \_ xs -> return (mkFoldMap xs)
919 where
920 -- mappend v1 (mappend v2 ..)
921 mkFoldMap :: [LHsExpr GhcPs] -> LHsExpr GhcPs
922 mkFoldMap [] = mempty_Expr
923 mkFoldMap xs = foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs
924
925 -- See Note [FFoldType and functorLikeTraverse]
926 -- Yields NullM an expression if we're folding over an expression
927 -- that may or may not be null. Yields IsNull if it's certainly
928 -- null, and yields NotNull if it's certainly not null.
929 -- See Note [Deriving null]
930 ft_null :: FFoldType (State [RdrName] (NullM (LHsExpr GhcPs)))
931 ft_null
932 = FT { ft_triv = return IsNull
933 -- null = \_ -> True
934 , ft_var = return NotNull
935 -- null = \_ -> False
936 , ft_tup = \t g -> do
937 gg <- sequence g
938 case convert gg of
939 Nothing -> pure NotNull
940 Just ggg ->
941 NullM <$> (mkSimpleLam $ mkSimpleTupleCase match_null t ggg)
942 -- null = \x -> case x of (..,)
943 , ft_ty_app = \_ _ g -> flip fmap g $ \nestedResult ->
944 case nestedResult of
945 -- If e definitely contains the parameter,
946 -- then we can test if (G e) contains it by
947 -- simply checking if (G e) is null
948 NotNull -> NullM null_Expr
949 -- This case is unreachable--it will actually be
950 -- caught by ft_triv
951 IsNull -> IsNull
952 -- The general case uses (all null),
953 -- (all (all null)), etc.
954 NullM nestedTest -> NullM $
955 nlHsApp all_Expr nestedTest
956 -- null fa = null fa, or null fa = all null fa, or null fa = True
957 , ft_forall = \_ g -> g
958 , ft_co_var = panic "contravariant in ft_null"
959 , ft_fun = panic "function in ft_null"
960 , ft_bad_app = panic "in other argument in ft_null" }
961
962 match_null :: Monad m
963 => [LPat GhcPs]
964 -> DataCon
965 -> [Maybe (LHsExpr GhcPs)]
966 -> m (LMatch GhcPs (LHsExpr GhcPs))
967 match_null = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkNull xs)
968 where
969 -- v1 && v2 && ..
970 mkNull :: [LHsExpr GhcPs] -> LHsExpr GhcPs
971 mkNull [] = true_Expr
972 mkNull xs = foldr1 (\x y -> nlHsApps and_RDR [x,y]) xs
973
974 data NullM a =
975 IsNull -- Definitely null
976 | NotNull -- Definitely not null
977 | NullM a -- Unknown
978
979 {-
980 ************************************************************************
981 * *
982 Traversable instances
983
984 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
985 * *
986 ************************************************************************
987
988 Again, Traversable is much like Functor and Foldable.
989
990 The cases are:
991
992 $(traverse 'a 'a) = f
993 $(traverse 'a '(b1,b2)) = \x -> case x of (x1,x2) ->
994 liftA2 (,) ($(traverse 'a 'b1) x1) ($(traverse 'a 'b2) x2)
995 $(traverse 'a '(T b1 b2)) = traverse $(traverse 'a 'b2) -- when a only occurs in the last parameter, b2
996
997 Like -XDeriveFoldable, -XDeriveTraversable filters out arguments whose types
998 do not mention the last type parameter. Therefore, the following datatype:
999
1000 data Foo a = Foo Int a Int
1001
1002 would have the following derived Traversable instance:
1003
1004 instance Traversable Foo where
1005 traverse f (Foo x1 x2 x3) =
1006 fmap (\b2 -> Foo x1 b2 x3) ( $(traverse 'a 'a) x2 )
1007
1008 since the two Int arguments do not produce any effects in a traversal.
1009
1010 One can envision a case for types that do not mention the last type parameter:
1011
1012 $(traverse 'a 'b) = pure -- when b does not contain a
1013
1014 But this case will never materialize, since the aforementioned filtering
1015 removes all such types from consideration.
1016 See Note [Generated code for DeriveFoldable and DeriveTraversable].
1017 -}
1018
1019 gen_Traversable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
1020 -- When the argument is phantom, we can use traverse = pure . coerce
1021 -- See Note [Phantom types with Functor, Foldable, and Traversable]
1022 gen_Traversable_binds loc tycon _
1023 | Phantom <- last (tyConRoles tycon)
1024 = (unitBag traverse_bind, emptyBag)
1025 where
1026 traverse_name = L (noAnnSrcSpan loc) traverse_RDR
1027 traverse_bind = mkRdrFunBind traverse_name traverse_eqns
1028 traverse_eqns =
1029 [mkSimpleMatch traverse_match_ctxt
1030 [nlWildPat, z_Pat]
1031 (nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])]
1032 traverse_match_ctxt = mkPrefixFunRhs traverse_name
1033
1034 gen_Traversable_binds loc tycon tycon_args
1035 = (unitBag traverse_bind, emptyBag)
1036 where
1037 data_cons = getPossibleDataCons tycon tycon_args
1038
1039 traverse_name = L (noAnnSrcSpan loc) traverse_RDR
1040
1041 -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
1042 traverse_bind = mkRdrFunBindEC 2 (nlHsApp pure_Expr)
1043 traverse_name traverse_eqns
1044 traverse_eqns = map traverse_eqn data_cons
1045 traverse_eqn con
1046 = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
1047 where
1048 parts = sequence $ foldDataConArgs ft_trav con
1049 traverse_match_ctxt = mkPrefixFunRhs traverse_name
1050
1051 -- Yields 'Just' an expression if we're folding over a type that mentions
1052 -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
1053 -- See Note [FFoldType and functorLikeTraverse]
1054 ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
1055 ft_trav
1056 = FT { ft_triv = return Nothing
1057 -- traverse f = pure x
1058 , ft_var = return (Just f_Expr)
1059 -- traverse f = f x
1060 , ft_tup = \t gs -> do
1061 gg <- sequence gs
1062 lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
1063 return (Just lam)
1064 -- traverse f = \x -> case x of (a1,a2,..) ->
1065 -- liftA2 (,,) (g1 a1) (g2 a2) <*> ..
1066 , ft_ty_app = \_ _ g -> fmap (nlHsApp traverse_Expr) <$> g
1067 -- traverse f = traverse g
1068 , ft_forall = \_ g -> g
1069 , ft_co_var = panic "contravariant in ft_trav"
1070 , ft_fun = panic "function in ft_trav"
1071 , ft_bad_app = panic "in other argument in ft_trav" }
1072
1073 -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)
1074 -- (g2 a2) <*> ...
1075 match_for_con :: Monad m
1076 => [LPat GhcPs]
1077 -> DataCon
1078 -> [Maybe (LHsExpr GhcPs)]
1079 -> m (LMatch GhcPs (LHsExpr GhcPs))
1080 match_for_con = mkSimpleConMatch2 traverse_match_ctxt $
1081 \con xs -> return (mkApCon con xs)
1082 where
1083 -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> ..
1084 mkApCon :: LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
1085 mkApCon con [] = nlHsApps pure_RDR [con]
1086 mkApCon con [x] = nlHsApps fmap_RDR [con,x]
1087 mkApCon con (x1:x2:xs) =
1088 foldl' appAp (nlHsApps liftA2_RDR [con,x1,x2]) xs
1089 where appAp x y = nlHsApps ap_RDR [x,y]
1090
1091 -----------------------------------------------------------------------
1092
1093 f_Expr, z_Expr, mempty_Expr, foldMap_Expr,
1094 traverse_Expr, coerce_Expr, pure_Expr, true_Expr, false_Expr,
1095 all_Expr, null_Expr :: LHsExpr GhcPs
1096 f_Expr = nlHsVar f_RDR
1097 z_Expr = nlHsVar z_RDR
1098 mempty_Expr = nlHsVar mempty_RDR
1099 foldMap_Expr = nlHsVar foldMap_RDR
1100 traverse_Expr = nlHsVar traverse_RDR
1101 coerce_Expr = nlHsVar (getRdrName coerceId)
1102 pure_Expr = nlHsVar pure_RDR
1103 true_Expr = nlHsVar true_RDR
1104 false_Expr = nlHsVar false_RDR
1105 all_Expr = nlHsVar all_RDR
1106 null_Expr = nlHsVar null_RDR
1107
1108 f_RDR, z_RDR :: RdrName
1109 f_RDR = mkVarUnqual (fsLit "f")
1110 z_RDR = mkVarUnqual (fsLit "z")
1111
1112 as_RDRs, bs_RDRs :: [RdrName]
1113 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1114 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1115
1116 as_Vars, bs_Vars :: [LHsExpr GhcPs]
1117 as_Vars = map nlHsVar as_RDRs
1118 bs_Vars = map nlHsVar bs_RDRs
1119
1120 f_Pat, z_Pat :: LPat GhcPs
1121 f_Pat = nlVarPat f_RDR
1122 z_Pat = nlVarPat z_RDR
1123
1124 {-
1125 Note [DeriveFoldable with ExistentialQuantification]
1126 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1127 Functor and Traversable instances can only be derived for data types whose
1128 last type parameter is truly universally polymorphic. For example:
1129
1130 data T a b where
1131 T1 :: b -> T a b -- YES, b is unconstrained
1132 T2 :: Ord b => b -> T a b -- NO, b is constrained by (Ord b)
1133 T3 :: b ~ Int => b -> T a b -- NO, b is constrained by (b ~ Int)
1134 T4 :: Int -> T a Int -- NO, this is just like T3
1135 T5 :: Ord a => a -> b -> T a b -- YES, b is unconstrained, even
1136 -- though a is existential
1137 T6 :: Int -> T Int b -- YES, b is unconstrained
1138
1139 For Foldable instances, however, we can completely lift the constraint that
1140 the last type parameter be truly universally polymorphic. This means that T
1141 (as defined above) can have a derived Foldable instance:
1142
1143 instance Foldable (T a) where
1144 foldr f z (T1 b) = f b z
1145 foldr f z (T2 b) = f b z
1146 foldr f z (T3 b) = f b z
1147 foldr f z (T4 b) = z
1148 foldr f z (T5 a b) = f b z
1149 foldr f z (T6 a) = z
1150
1151 foldMap f (T1 b) = f b
1152 foldMap f (T2 b) = f b
1153 foldMap f (T3 b) = f b
1154 foldMap f (T4 b) = mempty
1155 foldMap f (T5 a b) = f b
1156 foldMap f (T6 a) = mempty
1157
1158 In a Foldable instance, it is safe to fold over an occurrence of the last type
1159 parameter that is not truly universally polymorphic. However, there is a bit
1160 of subtlety in determining what is actually an occurrence of a type parameter.
1161 T3 and T4, as defined above, provide one example:
1162
1163 data T a b where
1164 ...
1165 T3 :: b ~ Int => b -> T a b
1166 T4 :: Int -> T a Int
1167 ...
1168
1169 instance Foldable (T a) where
1170 ...
1171 foldr f z (T3 b) = f b z
1172 foldr f z (T4 b) = z
1173 ...
1174 foldMap f (T3 b) = f b
1175 foldMap f (T4 b) = mempty
1176 ...
1177
1178 Notice that the argument of T3 is folded over, whereas the argument of T4 is
1179 not. This is because we only fold over constructor arguments that
1180 syntactically mention the universally quantified type parameter of that
1181 particular data constructor. See foldDataConArgs for how this is implemented.
1182
1183 As another example, consider the following data type. The argument of each
1184 constructor has the same type as the last type parameter:
1185
1186 data E a where
1187 E1 :: (a ~ Int) => a -> E a
1188 E2 :: Int -> E Int
1189 E3 :: (a ~ Int) => a -> E Int
1190 E4 :: (a ~ Int) => Int -> E a
1191
1192 Only E1's argument is an occurrence of a universally quantified type variable
1193 that is syntactically equivalent to the last type parameter, so only E1's
1194 argument will be folded over in a derived Foldable instance.
1195
1196 See #10447 for the original discussion on this feature. Also see
1197 https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/derive-functor
1198 for a more in-depth explanation.
1199
1200 Note [FFoldType and functorLikeTraverse]
1201 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1202 Deriving Functor, Foldable, and Traversable all require generating expressions
1203 which perform an operation on each argument of a data constructor depending
1204 on the argument's type. In particular, a generated operation can be different
1205 depending on whether the type mentions the last type variable of the datatype
1206 (e.g., if you have data T a = MkT a Int, then a generated foldr expression would
1207 fold over the first argument of MkT, but not the second).
1208
1209 This pattern is abstracted with the FFoldType datatype, which provides hooks
1210 for the user to specify how a constructor argument should be folded when it
1211 has a type with a particular "shape". The shapes are as follows (assume that
1212 a is the last type variable in a given datatype):
1213
1214 * ft_triv: The type does not mention the last type variable at all.
1215 Examples: Int, b
1216
1217 * ft_var: The type is syntactically equal to the last type variable.
1218 Moreover, the type appears in a covariant position (see
1219 the Deriving Functor instances section of the user's guide
1220 for an in-depth explanation of covariance vs. contravariance).
1221 Example: a (covariantly)
1222
1223 * ft_co_var: The type is syntactically equal to the last type variable.
1224 Moreover, the type appears in a contravariant position.
1225 Example: a (contravariantly)
1226
1227 * ft_fun: A function type which mentions the last type variable in
1228 the argument position, result position or both.
1229 Examples: a -> Int, Int -> a, Maybe a -> [a]
1230
1231 * ft_tup: A tuple type which mentions the last type variable in at least
1232 one of its fields. The TyCon argument of ft_tup represents the
1233 particular tuple's type constructor.
1234 Examples: (a, Int), (Maybe a, [a], Either a Int), (# Int, a #)
1235
1236 * ft_ty_app: A type is being applied to the last type parameter, where the
1237 applied type does not mention the last type parameter (if it
1238 did, it would fall under ft_bad_app) and the argument type
1239 mentions the last type parameter (if it did not, it would fall
1240 under ft_triv). The first two Type arguments to
1241 ft_ty_app represent the applied type and argument type,
1242 respectively.
1243
1244 Currently, only DeriveFunctor makes use of the argument type.
1245 It inspects the argument type so that it can generate more
1246 efficient implementations of fmap
1247 (see Note [Avoid unnecessary eta expansion in derived fmap implementations])
1248 and (<$) (see Note [Deriving <$]) in certain cases.
1249
1250 Note that functions, tuples, and foralls are distinct cases
1251 and take precedence over ft_ty_app. (For example, (Int -> a) would
1252 fall under (ft_fun Int a), not (ft_ty_app ((->) Int) a).
1253 Examples: Maybe a, Either b a
1254
1255 * ft_bad_app: A type application uses the last type parameter in a position
1256 other than the last argument. This case is singled out because
1257 Functor, Foldable, and Traversable instances cannot be derived
1258 for datatypes containing arguments with such types.
1259 Examples: Either a Int, Const a b
1260
1261 * ft_forall: A forall'd type mentions the last type parameter on its right-
1262 hand side (and is not quantified on the left-hand side). This
1263 case is present mostly for plumbing purposes.
1264 Example: forall b. Either b a
1265
1266 If FFoldType describes a strategy for folding subcomponents of a Type, then
1267 functorLikeTraverse is the function that applies that strategy to the entirety
1268 of a Type, returning the final folded-up result.
1269
1270 foldDataConArgs applies functorLikeTraverse to every argument type of a
1271 constructor, returning a list of the fold results. This makes foldDataConArgs
1272 a natural way to generate the subexpressions in a generated fmap, foldr,
1273 foldMap, or traverse definition (the subexpressions must then be combined in
1274 a method-specific fashion to form the final generated expression).
1275
1276 Deriving Generic1 also does validity checking by looking for the last type
1277 variable in certain positions of a constructor's argument types, so it also
1278 uses foldDataConArgs. See Note [degenerate use of FFoldType] in GHC.Tc.Deriv.Generics.
1279
1280 Note [Generated code for DeriveFoldable and DeriveTraversable]
1281 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1282 We adapt the algorithms for -XDeriveFoldable and -XDeriveTraversable based on
1283 that of -XDeriveFunctor. However, there an important difference between deriving
1284 the former two typeclasses and the latter one, which is best illustrated by the
1285 following scenario:
1286
1287 data WithInt a = WithInt a Int# deriving (Functor, Foldable, Traversable)
1288
1289 The generated code for the Functor instance is straightforward:
1290
1291 instance Functor WithInt where
1292 fmap f (WithInt a i) = WithInt (f a) i
1293
1294 But if we use too similar of a strategy for deriving the Foldable and
1295 Traversable instances, we end up with this code:
1296
1297 instance Foldable WithInt where
1298 foldMap f (WithInt a i) = f a <> mempty
1299
1300 instance Traversable WithInt where
1301 traverse f (WithInt a i) = fmap WithInt (f a) <*> pure i
1302
1303 This is unsatisfying for two reasons:
1304
1305 1. The Traversable instance doesn't typecheck! Int# is of kind #, but pure
1306 expects an argument whose type is of kind *. This effectively prevents
1307 Traversable from being derived for any datatype with an unlifted argument
1308 type (#11174).
1309
1310 2. The generated code contains superfluous expressions. By the Monoid laws,
1311 we can reduce (f a <> mempty) to (f a), and by the Applicative laws, we can
1312 reduce (fmap WithInt (f a) <*> pure i) to (fmap (\b -> WithInt b i) (f a)).
1313
1314 We can fix both of these issues by incorporating a slight twist to the usual
1315 algorithm that we use for -XDeriveFunctor. The differences can be summarized
1316 as follows:
1317
1318 1. In the generated expression, we only fold over arguments whose types
1319 mention the last type parameter. Any other argument types will simply
1320 produce useless 'mempty's or 'pure's, so they can be safely ignored.
1321
1322 2. In the case of -XDeriveTraversable, instead of applying ConName,
1323 we apply (\b_i ... b_k -> ConName a_1 ... a_n), where
1324
1325 * ConName has n arguments
1326 * {b_i, ..., b_k} is a subset of {a_1, ..., a_n} whose indices correspond
1327 to the arguments whose types mention the last type parameter. As a
1328 consequence, taking the difference of {a_1, ..., a_n} and
1329 {b_i, ..., b_k} yields the all the argument values of ConName whose types
1330 do not mention the last type parameter. Note that [i, ..., k] is a
1331 strictly increasing—but not necessarily consecutive—integer sequence.
1332
1333 For example, the datatype
1334
1335 data Foo a = Foo Int a Int a
1336
1337 would generate the following Traversable instance:
1338
1339 instance Traversable Foo where
1340 traverse f (Foo a1 a2 a3 a4) =
1341 fmap (\b2 b4 -> Foo a1 b2 a3 b4) (f a2) <*> f a4
1342
1343 Technically, this approach would also work for -XDeriveFunctor as well, but we
1344 decide not to do so because:
1345
1346 1. There's not much benefit to generating, e.g., ((\b -> WithInt b i) (f a))
1347 instead of (WithInt (f a) i).
1348
1349 2. There would be certain datatypes for which the above strategy would
1350 generate Functor code that would fail to typecheck. For example:
1351
1352 data Bar f a = Bar (forall f. Functor f => f a) deriving Functor
1353
1354 With the conventional algorithm, it would generate something like:
1355
1356 fmap f (Bar a) = Bar (fmap f a)
1357
1358 which typechecks. But with the strategy mentioned above, it would generate:
1359
1360 fmap f (Bar a) = (\b -> Bar b) (fmap f a)
1361
1362 which does not typecheck, since GHC cannot unify the rank-2 type variables
1363 in the types of b and (fmap f a).
1364
1365 Note [Phantom types with Functor, Foldable, and Traversable]
1366 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1367
1368 Given a type F :: * -> * whose type argument has a phantom role, we can always
1369 produce lawful Functor and Traversable instances using
1370
1371 fmap _ = coerce
1372 traverse _ = pure . coerce
1373
1374 Indeed, these are equivalent to any *strictly lawful* instances one could
1375 write, except that this definition of 'traverse' may be lazier. That is, if
1376 instances obey the laws under true equality (rather than up to some equivalence
1377 relation), then they will be essentially equivalent to these. These definitions
1378 are incredibly cheap, so we want to use them even if it means ignoring some
1379 non-strictly-lawful instance in an embedded type.
1380
1381 Foldable has far fewer laws to work with, which leaves us unwelcome
1382 freedom in implementing it. At a minimum, we would like to ensure that
1383 a derived foldMap is always at least as good as foldMapDefault with a
1384 derived traverse. To accomplish that, we must define
1385
1386 foldMap _ _ = mempty
1387
1388 in these cases.
1389
1390 This may have different strictness properties from a standard derivation.
1391 Consider
1392
1393 data NotAList a = Nil | Cons (NotAList a) deriving Foldable
1394
1395 The usual deriving mechanism would produce
1396
1397 foldMap _ Nil = mempty
1398 foldMap f (Cons x) = foldMap f x
1399
1400 which is strict in the entire spine of the NotAList.
1401
1402 Final point: why do we even care about such types? Users will rarely if ever
1403 map, fold, or traverse over such things themselves, but other derived
1404 instances may:
1405
1406 data Hasn'tAList a = NotHere a (NotAList a) deriving Foldable
1407
1408 Note [EmptyDataDecls with Functor, Foldable, and Traversable]
1409 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1410
1411 There are some slightly tricky decisions to make about how to handle
1412 Functor, Foldable, and Traversable instances for types with no constructors.
1413 For fmap, the two basic options are
1414
1415 fmap _ _ = error "Sorry, no constructors"
1416
1417 or
1418
1419 fmap _ z = case z of
1420
1421 In most cases, the latter is more helpful: if the thunk passed to fmap
1422 throws an exception, we're generally going to be much more interested in
1423 that exception than in the fact that there aren't any constructors.
1424
1425 In order to match the semantics for phantoms (see note above), we need to
1426 be a bit careful about 'traverse'. The obvious definition would be
1427
1428 traverse _ z = case z of
1429
1430 but this is stricter than the one for phantoms. We instead use
1431
1432 traverse _ z = pure $ case z of
1433
1434 For foldMap, the obvious choices are
1435
1436 foldMap _ _ = mempty
1437
1438 or
1439
1440 foldMap _ z = case z of
1441
1442 We choose the first one to be consistent with what foldMapDefault does for
1443 a derived Traversable instance.
1444 -}