Revert recent submodule bumps
[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 = (listToBag [fmap_bind, replace_bind], emptyBag)
129 where
130 data_cons = tyConDataCons tycon
131 fmap_name = L loc fmap_RDR
132 fmap_bind = mkRdrFunBind fmap_name fmap_eqns
133 fmap_match_ctxt = FunRhs fmap_name Prefix
134
135 fmap_eqn con = flip evalState bs_RDRs $
136 match_for_con fmap_match_ctxt [f_Pat] con =<< parts
137 where
138 parts = sequence $ foldDataConArgs ft_fmap con
139
140 fmap_eqns
141 | null data_cons = [mkSimpleMatch fmap_match_ctxt
142 [nlWildPat, nlWildPat]
143 (error_Expr "Void fmap")]
144 | otherwise = map fmap_eqn data_cons
145
146 ft_fmap :: FFoldType (State [RdrName] (LHsExpr RdrName))
147 ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x
148 -- fmap f = \x -> x
149 , ft_var = return f_Expr
150 -- fmap f = f
151 , ft_fun = \g h -> do
152 gg <- g
153 hh <- h
154 mkSimpleLam2 $ \x b -> return $
155 nlHsApp hh (nlHsApp x (nlHsApp gg b))
156 -- fmap f = \x b -> h (x (g b))
157 , ft_tup = \t gs -> do
158 gg <- sequence gs
159 mkSimpleLam $ mkSimpleTupleCase (match_for_con CaseAlt) t gg
160 -- fmap f = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
161 , ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g
162 -- fmap f = fmap g
163 , ft_forall = \_ g -> g
164 , ft_bad_app = panic "in other argument"
165 , ft_co_var = panic "contravariant" }
166
167 -- See Note [deriving <$]
168 replace_name = L loc replace_RDR
169 replace_bind = mkRdrFunBind replace_name replace_eqns
170 replace_match_ctxt = FunRhs replace_name Prefix
171
172 replace_eqn con = flip evalState bs_RDRs $
173 match_for_con replace_match_ctxt [z_Pat] con =<< parts
174 where
175 parts = traverse (fmap replace) $ foldDataConArgs ft_replace con
176
177 replace_eqns
178 | null data_cons = [mkSimpleMatch replace_match_ctxt
179 [nlWildPat, nlWildPat]
180 (error_Expr "Void <$")]
181 | otherwise = map replace_eqn data_cons
182
183 ft_replace :: FFoldType (State [RdrName] Replacer)
184 ft_replace = FT { ft_triv = fmap Nested $ mkSimpleLam $ \x -> return x
185 -- (p <$) = \x -> x
186 , ft_var = fmap Immediate $ mkSimpleLam $ \_ -> return z_Expr
187 -- (p <$) = const p
188 , ft_fun = \g h -> do
189 gg <- replace <$> g
190 hh <- replace <$> h
191 fmap Nested $ mkSimpleLam2 $ \x b -> return $
192 nlHsApp hh (nlHsApp x (nlHsApp gg b))
193 -- (<$) p = \x b -> h (x (g b))
194 , ft_tup = \t gs -> do
195 gg <- traverse (fmap replace) gs
196 fmap Nested . mkSimpleLam $
197 mkSimpleTupleCase (match_for_con CaseAlt) t gg
198 -- (p <$) = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
199 , ft_ty_app = \_ gm -> do
200 g <- gm
201 case g of
202 Nested g' -> pure . Nested $
203 nlHsApp fmap_Expr $ g'
204 Immediate _ -> pure . Nested $
205 nlHsApp replace_Expr z_Expr
206 -- (p <$) = fmap (p <$)
207 , ft_forall = \_ g -> g
208 , ft_bad_app = panic "in other argument"
209 , ft_co_var = panic "contravariant" }
210
211 -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
212 match_for_con :: HsMatchContext RdrName
213 -> [LPat RdrName] -> DataCon -> [LHsExpr RdrName]
214 -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
215 match_for_con ctxt = mkSimpleConMatch ctxt $
216 \con_name xs -> return $ nlHsApps con_name xs -- Con x1 x2 ..
217
218 -- See Note [deriving <$]
219 data Replacer = Immediate {replace :: LHsExpr RdrName}
220 | Nested {replace :: LHsExpr RdrName}
221
222 {- Note [deriving <$]
223 ~~~~~~~~~~~~~~~~~~
224
225 We derive the definition of <$. Allowing this to take the default definition
226 can lead to memory leaks: mapping over a structure with a constant function can
227 fill the result structure with trivial thunks that retain the values from the
228 original structure. The simplifier seems to handle this all right for simple
229 types, but not for recursive ones. Consider
230
231 data Tree a = Bin !(Tree a) a !(Tree a) | Tip deriving Functor
232
233 -- fmap _ Tip = Tip
234 -- fmap f (Bin l v r) = Bin (fmap f l) (f v) (fmap f r)
235
236 Using the default definition of <$, we get (<$) x = fmap (\_ -> x) and that
237 simplifies no further. Why is that? `fmap` is defined recursively, so GHC
238 cannot inline it. The static argument transformation would turn the definition
239 into a non-recursive one
240
241 -- fmap f = go where
242 -- go Tip = Tip
243 -- go (Bin l v r) = Bin (go l) (f v) (go r)
244
245 which GHC could inline, producing an efficient definion of `<$`. But there are
246 several problems. First, GHC does not perform the static argument transformation
247 by default, even with -O2. Second, even when it does perform the static argument
248 transformation, it does so only when there are at least two static arguments,
249 which is not the case for fmap. Finally, when the type in question is
250 non-regular, such as
251
252 data Nesty a = Z a | S (Nesty a) (Nest (a, a))
253
254 the function argument is no longer (entirely) static, so the static argument
255 transformation will do nothing for us.
256
257 Applying the default definition of `<$` will produce a tree full of thunks that
258 look like ((\_ -> x) x0), which represents unnecessary thunk allocation and
259 also retention of the previous value, potentially leaking memory. Instead, we
260 derive <$ separately. Two aspects are different from fmap: the case of the
261 sought type variable (ft_var) and the case of a type application (ft_ty_app).
262 The interesting one is ft_ty_app. We have to distinguish two cases: the
263 "immediate" case where the type argument *is* the sought type variable, and
264 the "nested" case where the type argument *contains* the sought type variable.
265
266 The immediate case:
267
268 Suppose we have
269
270 data Imm a = Imm (F ... a)
271
272 Then we want to define
273
274 x <$ Imm q = Imm (x <$ q)
275
276 The nested case:
277
278 Suppose we have
279
280 data Nes a = Nes (F ... (G a))
281
282 Then we want to define
283
284 x <$ Nes q = Nes (fmap (x <$) q)
285
286 We use the Replacer type to tag whether the expression derived for applying
287 <$ to the last type variable was the ft_var case (immediate) or one of the
288 others (letting ft_forall pass through as usual).
289
290 We could, but do not, give tuples special treatment to improve efficiency
291 in some cases. Suppose we have
292
293 data Nest a = Z a | S (Nest (a,a))
294
295 The optimal definition would be
296
297 x <$ Z _ = Z x
298 x <$ S t = S ((x, x) <$ t)
299
300 which produces a result with maximal internal sharing. The reason we do not
301 attempt to treat this case specially is that we have no way to give
302 user-provided tuple-like types similar treatment. If the user changed the
303 definition to
304
305 data Pair a = Pair a a
306 data Nest a = Z a | S (Nest (Pair a))
307
308 they would experience a surprising degradation in performance. -}
309
310
311 {-
312 Utility functions related to Functor deriving.
313
314 Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
315 This function works like a fold: it makes a value of type 'a' in a bottom up way.
316 -}
317
318 -- Generic traversal for Functor deriving
319 -- See Note [FFoldType and functorLikeTraverse]
320 data FFoldType a -- Describes how to fold over a Type in a functor like way
321 = FT { ft_triv :: a
322 -- ^ Does not contain variable
323 , ft_var :: a
324 -- ^ The variable itself
325 , ft_co_var :: a
326 -- ^ The variable itself, contravariantly
327 , ft_fun :: a -> a -> a
328 -- ^ Function type
329 , ft_tup :: TyCon -> [a] -> a
330 -- ^ Tuple type
331 , ft_ty_app :: Type -> a -> a
332 -- ^ Type app, variable only in last argument
333 , ft_bad_app :: a
334 -- ^ Type app, variable other than in last argument
335 , ft_forall :: TcTyVar -> a -> a
336 -- ^ Forall type
337 }
338
339 functorLikeTraverse :: forall a.
340 TyVar -- ^ Variable to look for
341 -> FFoldType a -- ^ How to fold
342 -> Type -- ^ Type to process
343 -> a
344 functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar
345 , ft_co_var = caseCoVar, ft_fun = caseFun
346 , ft_tup = caseTuple, ft_ty_app = caseTyApp
347 , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
348 ty
349 = fst (go False ty)
350 where
351 go :: Bool -- Covariant or contravariant context
352 -> Type
353 -> (a, Bool) -- (result of type a, does type contain var)
354
355 go co ty | Just ty' <- coreView ty = go co ty'
356 go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True)
357 go co (FunTy x y) | isPredTy x = go co y
358 | xc || yc = (caseFun xr yr,True)
359 where (xr,xc) = go (not co) x
360 (yr,yc) = go co y
361 go co (AppTy x y) | xc = (caseWrongArg, True)
362 | yc = (caseTyApp x yr, True)
363 where (_, xc) = go co x
364 (yr,yc) = go co y
365 go co ty@(TyConApp con args)
366 | not (or xcs) = (caseTrivial, False) -- Variable does not occur
367 -- At this point we know that xrs, xcs is not empty,
368 -- and at least one xr is True
369 | isTupleTyCon con = (caseTuple con xrs, True)
370 | or (init xcs) = (caseWrongArg, True) -- T (..var..) ty
371 | Just (fun_ty, _) <- splitAppTy_maybe ty -- T (..no var..) ty
372 = (caseTyApp fun_ty (last xrs), True)
373 | otherwise = (caseWrongArg, True) -- Non-decomposable (eg type function)
374 where
375 -- When folding over an unboxed tuple, we must explicitly drop the
376 -- runtime rep arguments, or else GHC will generate twice as many
377 -- variables in a unboxed tuple pattern match and expression as it
378 -- actually needs. See Trac #12399
379 (xrs,xcs) = unzip (map (go co) (dropRuntimeRepArgs args))
380 go co (ForAllTy (TvBndr v vis) x)
381 | isVisibleArgFlag vis = panic "unexpected visible binder"
382 | v /= var && xc = (caseForAll v xr,True)
383 where (xr,xc) = go co x
384
385 go _ _ = (caseTrivial,False)
386
387 -- Return all syntactic subterms of ty that contain var somewhere
388 -- These are the things that should appear in instance constraints
389 deepSubtypesContaining :: TyVar -> Type -> [TcType]
390 deepSubtypesContaining tv
391 = functorLikeTraverse tv
392 (FT { ft_triv = []
393 , ft_var = []
394 , ft_fun = (++)
395 , ft_tup = \_ xs -> concat xs
396 , ft_ty_app = (:)
397 , ft_bad_app = panic "in other argument"
398 , ft_co_var = panic "contravariant"
399 , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs })
400
401
402 foldDataConArgs :: FFoldType a -> DataCon -> [a]
403 -- Fold over the arguments of the datacon
404 foldDataConArgs ft con
405 = map foldArg (dataConOrigArgTys con)
406 where
407 foldArg
408 = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of
409 Just tv -> functorLikeTraverse tv ft
410 Nothing -> const (ft_triv ft)
411 -- If we are deriving Foldable for a GADT, there is a chance that the last
412 -- type variable in the data type isn't actually a type variable at all.
413 -- (for example, this can happen if the last type variable is refined to
414 -- be a concrete type such as Int). If the last type variable is refined
415 -- to be a specific type, then getTyVar_maybe will return Nothing.
416 -- See Note [DeriveFoldable with ExistentialQuantification]
417 --
418 -- The kind checks have ensured the last type parameter is of kind *.
419
420 -- Make a HsLam using a fresh variable from a State monad
421 mkSimpleLam :: (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
422 -> State [RdrName] (LHsExpr RdrName)
423 -- (mkSimpleLam fn) returns (\x. fn(x))
424 mkSimpleLam lam = do
425 (n:names) <- get
426 put names
427 body <- lam (nlHsVar n)
428 return (mkHsLam [nlVarPat n] body)
429
430 mkSimpleLam2 :: (LHsExpr RdrName -> LHsExpr RdrName
431 -> State [RdrName] (LHsExpr RdrName))
432 -> State [RdrName] (LHsExpr RdrName)
433 mkSimpleLam2 lam = do
434 (n1:n2:names) <- get
435 put names
436 body <- lam (nlHsVar n1) (nlHsVar n2)
437 return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
438
439 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
440 --
441 -- @mkSimpleConMatch fold extra_pats con insides@ produces a match clause in
442 -- which the LHS pattern-matches on @extra_pats@, followed by a match on the
443 -- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@
444 -- and its arguments, applying an expression (from @insides@) to each of the
445 -- respective arguments of @con@.
446 mkSimpleConMatch :: Monad m => HsMatchContext RdrName
447 -> (RdrName -> [LHsExpr RdrName] -> m (LHsExpr RdrName))
448 -> [LPat RdrName]
449 -> DataCon
450 -> [LHsExpr RdrName]
451 -> m (LMatch RdrName (LHsExpr RdrName))
452 mkSimpleConMatch ctxt fold extra_pats con insides = do
453 let con_name = getRdrName con
454 let vars_needed = takeList insides as_RDRs
455 let bare_pat = nlConVarPat con_name vars_needed
456 let pat = if null vars_needed
457 then bare_pat
458 else nlParPat bare_pat
459 rhs <- fold con_name (zipWith nlHsApp insides (map nlHsVar vars_needed))
460 return $ mkMatch ctxt (extra_pats ++ [pat]) rhs
461 (noLoc emptyLocalBinds)
462
463 -- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)"
464 --
465 -- @mkSimpleConMatch2 fold extra_pats con insides@ behaves very similarly to
466 -- 'mkSimpleConMatch', with two key differences:
467 --
468 -- 1. @insides@ is a @[Maybe (LHsExpr RdrName)]@ instead of a
469 -- @[LHsExpr RdrName]@. This is because it filters out the expressions
470 -- corresponding to arguments whose types do not mention the last type
471 -- variable in a derived 'Foldable' or 'Traversable' instance (i.e., the
472 -- 'Nothing' elements of @insides@).
473 --
474 -- 2. @fold@ takes an expression as its first argument instead of a
475 -- constructor name. This is because it uses a specialized
476 -- constructor function expression that only takes as many parameters as
477 -- there are argument types that mention the last type variable.
478 --
479 -- See Note [Generated code for DeriveFoldable and DeriveTraversable]
480 mkSimpleConMatch2 :: Monad m
481 => HsMatchContext RdrName
482 -> (LHsExpr RdrName -> [LHsExpr RdrName]
483 -> m (LHsExpr RdrName))
484 -> [LPat RdrName]
485 -> DataCon
486 -> [Maybe (LHsExpr RdrName)]
487 -> m (LMatch RdrName (LHsExpr RdrName))
488 mkSimpleConMatch2 ctxt fold extra_pats con insides = do
489 let con_name = getRdrName con
490 vars_needed = takeList insides as_RDRs
491 pat = nlConVarPat con_name vars_needed
492 -- Make sure to zip BEFORE invoking catMaybes. We want the variable
493 -- indicies in each expression to match up with the argument indices
494 -- in con_expr (defined below).
495 exps = catMaybes $ zipWith (\i v -> (`nlHsApp` v) <$> i)
496 insides (map nlHsVar vars_needed)
497 -- An element of argTysTyVarInfo is True if the constructor argument
498 -- with the same index has a type which mentions the last type
499 -- variable.
500 argTysTyVarInfo = map isJust insides
501 (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_RDRs
502
503 con_expr
504 | null asWithTyVar = nlHsApps con_name $ map nlHsVar asWithoutTyVar
505 | otherwise =
506 let bs = filterByList argTysTyVarInfo bs_RDRs
507 vars = filterByLists argTysTyVarInfo
508 (map nlHsVar bs_RDRs)
509 (map nlHsVar as_RDRs)
510 in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars)
511
512 rhs <- fold con_expr exps
513 return $ mkMatch ctxt (extra_pats ++ [pat]) rhs
514 (noLoc emptyLocalBinds)
515
516 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
517 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [a]
518 -> m (LMatch RdrName (LHsExpr RdrName)))
519 -> TyCon -> [a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
520 mkSimpleTupleCase match_for_con tc insides x
521 = do { let data_con = tyConSingleDataCon tc
522 ; match <- match_for_con [] data_con insides
523 ; return $ nlHsCase x [match] }
524
525 {-
526 ************************************************************************
527 * *
528 Foldable instances
529
530 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
531
532 * *
533 ************************************************************************
534
535 Deriving Foldable instances works the same way as Functor instances,
536 only Foldable instances are not possible for function types at all.
537 Given (data T a = T a a (T a) deriving Foldable), we get:
538
539 instance Foldable T where
540 foldr f z (T x1 x2 x3) =
541 $(foldr 'a 'a) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a '(T a)) x3 z ) )
542
543 -XDeriveFoldable is different from -XDeriveFunctor in that it filters out
544 arguments to the constructor that would produce useless code in a Foldable
545 instance. For example, the following datatype:
546
547 data Foo a = Foo Int a Int deriving Foldable
548
549 would have the following generated Foldable instance:
550
551 instance Foldable Foo where
552 foldr f z (Foo x1 x2 x3) = $(foldr 'a 'a) x2
553
554 since neither of the two Int arguments are folded over.
555
556 The cases are:
557
558 $(foldr 'a 'a) = f
559 $(foldr 'a '(b1,b2)) = \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
560 $(foldr 'a '(T b1 b2)) = \x z -> foldr $(foldr 'a 'b2) z x -- when a only occurs in the last parameter, b2
561
562 Note that the arguments to the real foldr function are the wrong way around,
563 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
564
565 One can envision a case for types that don't contain the last type variable:
566
567 $(foldr 'a 'b) = \x z -> z -- when b does not contain a
568
569 But this case will never materialize, since the aforementioned filtering
570 removes all such types from consideration.
571 See Note [Generated code for DeriveFoldable and DeriveTraversable].
572
573 Foldable instances differ from Functor and Traversable instances in that
574 Foldable instances can be derived for data types in which the last type
575 variable is existentially quantified. In particular, if the last type variable
576 is refined to a more specific type in a GADT:
577
578 data GADT a where
579 G :: a ~ Int => a -> G Int
580
581 then the deriving machinery does not attempt to check that the type a contains
582 Int, since it is not syntactically equal to a type variable. That is, the
583 derived Foldable instance for GADT is:
584
585 instance Foldable GADT where
586 foldr _ z (GADT _) = z
587
588 See Note [DeriveFoldable with ExistentialQuantification].
589
590 -}
591
592 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
593 gen_Foldable_binds loc tycon
594 = (listToBag [foldr_bind, foldMap_bind], emptyBag)
595 where
596 data_cons = tyConDataCons tycon
597
598 foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns
599 eqns = map foldr_eqn data_cons
600 foldr_eqn con
601 = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs
602 where
603 parts = sequence $ foldDataConArgs ft_foldr con
604
605 foldMap_bind = mkRdrFunBind (L loc foldMap_RDR) (map foldMap_eqn data_cons)
606 foldMap_eqn con
607 = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs
608 where
609 parts = sequence $ foldDataConArgs ft_foldMap con
610
611 -- Yields 'Just' an expression if we're folding over a type that mentions
612 -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
613 -- See Note [FFoldType and functorLikeTraverse]
614 ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName)))
615 ft_foldr
616 = FT { ft_triv = return Nothing
617 -- foldr f = \x z -> z
618 , ft_var = return $ Just f_Expr
619 -- foldr f = f
620 , ft_tup = \t g -> do
621 gg <- sequence g
622 lam <- mkSimpleLam2 $ \x z ->
623 mkSimpleTupleCase (match_foldr z) t gg x
624 return (Just lam)
625 -- foldr f = (\x z -> case x of ...)
626 , ft_ty_app = \_ g -> do
627 gg <- g
628 mapM (\gg' -> mkSimpleLam2 $ \x z -> return $
629 nlHsApps foldable_foldr_RDR [gg',z,x]) gg
630 -- foldr f = (\x z -> foldr g z x)
631 , ft_forall = \_ g -> g
632 , ft_co_var = panic "contravariant"
633 , ft_fun = panic "function"
634 , ft_bad_app = panic "in other argument" }
635
636 match_foldr :: LHsExpr RdrName
637 -> [LPat RdrName]
638 -> DataCon
639 -> [Maybe (LHsExpr RdrName)]
640 -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
641 match_foldr z = mkSimpleConMatch2 LambdaExpr $ \_ xs -> return (mkFoldr xs)
642 where
643 -- g1 v1 (g2 v2 (.. z))
644 mkFoldr :: [LHsExpr RdrName] -> LHsExpr RdrName
645 mkFoldr = foldr nlHsApp z
646
647 -- See Note [FFoldType and functorLikeTraverse]
648 ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName)))
649 ft_foldMap
650 = FT { ft_triv = return Nothing
651 -- foldMap f = \x -> mempty
652 , ft_var = return (Just f_Expr)
653 -- foldMap f = f
654 , ft_tup = \t g -> do
655 gg <- sequence g
656 lam <- mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg
657 return (Just lam)
658 -- foldMap f = \x -> case x of (..,)
659 , ft_ty_app = \_ g -> fmap (nlHsApp foldMap_Expr) <$> g
660 -- foldMap f = foldMap g
661 , ft_forall = \_ g -> g
662 , ft_co_var = panic "contravariant"
663 , ft_fun = panic "function"
664 , ft_bad_app = panic "in other argument" }
665
666 match_foldMap :: [LPat RdrName]
667 -> DataCon
668 -> [Maybe (LHsExpr RdrName)]
669 -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
670 match_foldMap = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkFoldMap xs)
671 where
672 -- mappend v1 (mappend v2 ..)
673 mkFoldMap :: [LHsExpr RdrName] -> LHsExpr RdrName
674 mkFoldMap [] = mempty_Expr
675 mkFoldMap xs = foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs
676
677 {-
678 ************************************************************************
679 * *
680 Traversable instances
681
682 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
683 * *
684 ************************************************************************
685
686 Again, Traversable is much like Functor and Foldable.
687
688 The cases are:
689
690 $(traverse 'a 'a) = f
691 $(traverse 'a '(b1,b2)) = \x -> case x of (x1,x2) ->
692 liftA2 (,) ($(traverse 'a 'b1) x1) ($(traverse 'a 'b2) x2)
693 $(traverse 'a '(T b1 b2)) = traverse $(traverse 'a 'b2) -- when a only occurs in the last parameter, b2
694
695 Like -XDeriveFoldable, -XDeriveTraversable filters out arguments whose types
696 do not mention the last type parameter. Therefore, the following datatype:
697
698 data Foo a = Foo Int a Int
699
700 would have the following derived Traversable instance:
701
702 instance Traversable Foo where
703 traverse f (Foo x1 x2 x3) =
704 fmap (\b2 -> Foo x1 b2 x3) ( $(traverse 'a 'a) x2 )
705
706 since the two Int arguments do not produce any effects in a traversal.
707
708 One can envision a case for types that do not mention the last type parameter:
709
710 $(traverse 'a 'b) = pure -- when b does not contain a
711
712 But this case will never materialize, since the aforementioned filtering
713 removes all such types from consideration.
714 See Note [Generated code for DeriveFoldable and DeriveTraversable].
715 -}
716
717 gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
718 gen_Traversable_binds loc tycon
719 = (unitBag traverse_bind, emptyBag)
720 where
721 data_cons = tyConDataCons tycon
722
723 traverse_bind = mkRdrFunBind (L loc traverse_RDR) eqns
724 eqns = map traverse_eqn data_cons
725 traverse_eqn con
726 = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
727 where
728 parts = sequence $ foldDataConArgs ft_trav con
729
730 -- Yields 'Just' an expression if we're folding over a type that mentions
731 -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
732 -- See Note [FFoldType and functorLikeTraverse]
733 ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName)))
734 ft_trav
735 = FT { ft_triv = return Nothing
736 -- traverse f = pure x
737 , ft_var = return (Just f_Expr)
738 -- traverse f = f x
739 , ft_tup = \t gs -> do
740 gg <- sequence gs
741 lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
742 return (Just lam)
743 -- traverse f = \x -> case x of (a1,a2,..) ->
744 -- liftA2 (,,) (g1 a1) (g2 a2) <*> ..
745 , ft_ty_app = \_ g -> fmap (nlHsApp traverse_Expr) <$> g
746 -- traverse f = traverse g
747 , ft_forall = \_ g -> g
748 , ft_co_var = panic "contravariant"
749 , ft_fun = panic "function"
750 , ft_bad_app = panic "in other argument" }
751
752 -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)
753 -- (g2 a2) <*> ...
754 match_for_con :: [LPat RdrName]
755 -> DataCon
756 -> [Maybe (LHsExpr RdrName)]
757 -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
758 match_for_con = mkSimpleConMatch2 CaseAlt $
759 \con xs -> return (mkApCon con xs)
760 where
761 -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> ..
762 mkApCon :: LHsExpr RdrName -> [LHsExpr RdrName] -> LHsExpr RdrName
763 mkApCon con [] = nlHsApps pure_RDR [con]
764 mkApCon con [x] = nlHsApps fmap_RDR [con,x]
765 mkApCon con (x1:x2:xs) =
766 foldl appAp (nlHsApps liftA2_RDR [con,x1,x2]) xs
767 where appAp x y = nlHsApps ap_RDR [x,y]
768
769 -----------------------------------------------------------------------
770
771 f_Expr, z_Expr, fmap_Expr, replace_Expr, mempty_Expr, foldMap_Expr,
772 traverse_Expr :: LHsExpr RdrName
773 f_Expr = nlHsVar f_RDR
774 z_Expr = nlHsVar z_RDR
775 fmap_Expr = nlHsVar fmap_RDR
776 replace_Expr = nlHsVar replace_RDR
777 mempty_Expr = nlHsVar mempty_RDR
778 foldMap_Expr = nlHsVar foldMap_RDR
779 traverse_Expr = nlHsVar traverse_RDR
780
781 f_RDR, z_RDR :: RdrName
782 f_RDR = mkVarUnqual (fsLit "f")
783 z_RDR = mkVarUnqual (fsLit "z")
784
785 as_RDRs, bs_RDRs :: [RdrName]
786 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
787 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
788
789 f_Pat, z_Pat :: LPat RdrName
790 f_Pat = nlVarPat f_RDR
791 z_Pat = nlVarPat z_RDR
792
793 {-
794 Note [DeriveFoldable with ExistentialQuantification]
795 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
796 Functor and Traversable instances can only be derived for data types whose
797 last type parameter is truly universally polymorphic. For example:
798
799 data T a b where
800 T1 :: b -> T a b -- YES, b is unconstrained
801 T2 :: Ord b => b -> T a b -- NO, b is constrained by (Ord b)
802 T3 :: b ~ Int => b -> T a b -- NO, b is constrained by (b ~ Int)
803 T4 :: Int -> T a Int -- NO, this is just like T3
804 T5 :: Ord a => a -> b -> T a b -- YES, b is unconstrained, even
805 -- though a is existential
806 T6 :: Int -> T Int b -- YES, b is unconstrained
807
808 For Foldable instances, however, we can completely lift the constraint that
809 the last type parameter be truly universally polymorphic. This means that T
810 (as defined above) can have a derived Foldable instance:
811
812 instance Foldable (T a) where
813 foldr f z (T1 b) = f b z
814 foldr f z (T2 b) = f b z
815 foldr f z (T3 b) = f b z
816 foldr f z (T4 b) = z
817 foldr f z (T5 a b) = f b z
818 foldr f z (T6 a) = z
819
820 foldMap f (T1 b) = f b
821 foldMap f (T2 b) = f b
822 foldMap f (T3 b) = f b
823 foldMap f (T4 b) = mempty
824 foldMap f (T5 a b) = f b
825 foldMap f (T6 a) = mempty
826
827 In a Foldable instance, it is safe to fold over an occurrence of the last type
828 parameter that is not truly universally polymorphic. However, there is a bit
829 of subtlety in determining what is actually an occurrence of a type parameter.
830 T3 and T4, as defined above, provide one example:
831
832 data T a b where
833 ...
834 T3 :: b ~ Int => b -> T a b
835 T4 :: Int -> T a Int
836 ...
837
838 instance Foldable (T a) where
839 ...
840 foldr f z (T3 b) = f b z
841 foldr f z (T4 b) = z
842 ...
843 foldMap f (T3 b) = f b
844 foldMap f (T4 b) = mempty
845 ...
846
847 Notice that the argument of T3 is folded over, whereas the argument of T4 is
848 not. This is because we only fold over constructor arguments that
849 syntactically mention the universally quantified type parameter of that
850 particular data constructor. See foldDataConArgs for how this is implemented.
851
852 As another example, consider the following data type. The argument of each
853 constructor has the same type as the last type parameter:
854
855 data E a where
856 E1 :: (a ~ Int) => a -> E a
857 E2 :: Int -> E Int
858 E3 :: (a ~ Int) => a -> E Int
859 E4 :: (a ~ Int) => Int -> E a
860
861 Only E1's argument is an occurrence of a universally quantified type variable
862 that is syntactically equivalent to the last type parameter, so only E1's
863 argument will be be folded over in a derived Foldable instance.
864
865 See Trac #10447 for the original discussion on this feature. Also see
866 https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor
867 for a more in-depth explanation.
868
869 Note [FFoldType and functorLikeTraverse]
870 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
871 Deriving Functor, Foldable, and Traversable all require generating expressions
872 which perform an operation on each argument of a data constructor depending
873 on the argument's type. In particular, a generated operation can be different
874 depending on whether the type mentions the last type variable of the datatype
875 (e.g., if you have data T a = MkT a Int, then a generated foldr expression would
876 fold over the first argument of MkT, but not the second).
877
878 This pattern is abstracted with the FFoldType datatype, which provides hooks
879 for the user to specify how a constructor argument should be folded when it
880 has a type with a particular "shape". The shapes are as follows (assume that
881 a is the last type variable in a given datatype):
882
883 * ft_triv: The type does not mention the last type variable at all.
884 Examples: Int, b
885
886 * ft_var: The type is syntactically equal to the last type variable.
887 Moreover, the type appears in a covariant position (see
888 the Deriving Functor instances section of the user's guide
889 for an in-depth explanation of covariance vs. contravariance).
890 Example: a (covariantly)
891
892 * ft_co_var: The type is syntactically equal to the last type variable.
893 Moreover, the type appears in a contravariant position.
894 Example: a (contravariantly)
895
896 * ft_fun: A function type which mentions the last type variable in
897 the argument position, result position or both.
898 Examples: a -> Int, Int -> a, Maybe a -> [a]
899
900 * ft_tup: A tuple type which mentions the last type variable in at least
901 one of its fields. The TyCon argument of ft_tup represents the
902 particular tuple's type constructor.
903 Examples: (a, Int), (Maybe a, [a], Either a Int), (# Int, a #)
904
905 * ft_ty_app: A type is being applied to the last type parameter, where the
906 applied type does not mention the last type parameter (if it
907 did, it would fall under ft_bad_app). The Type argument to
908 ft_ty_app represents the applied type.
909
910 Note that functions, tuples, and foralls are distinct cases
911 and take precedence of ft_ty_app. (For example, (Int -> a) would
912 fall under (ft_fun Int a), not (ft_ty_app ((->) Int) a).
913 Examples: Maybe a, Either b a
914
915 * ft_bad_app: A type application uses the last type parameter in a position
916 other than the last argument. This case is singled out because
917 Functor, Foldable, and Traversable instances cannot be derived
918 for datatypes containing arguments with such types.
919 Examples: Either a Int, Const a b
920
921 * ft_forall: A forall'd type mentions the last type parameter on its right-
922 hand side (and is not quantified on the left-hand side). This
923 case is present mostly for plumbing purposes.
924 Example: forall b. Either b a
925
926 If FFoldType describes a strategy for folding subcomponents of a Type, then
927 functorLikeTraverse is the function that applies that strategy to the entirety
928 of a Type, returning the final folded-up result.
929
930 foldDataConArgs applies functorLikeTraverse to every argument type of a
931 constructor, returning a list of the fold results. This makes foldDataConArgs
932 a natural way to generate the subexpressions in a generated fmap, foldr,
933 foldMap, or traverse definition (the subexpressions must then be combined in
934 a method-specific fashion to form the final generated expression).
935
936 Deriving Generic1 also does validity checking by looking for the last type
937 variable in certain positions of a constructor's argument types, so it also
938 uses foldDataConArgs. See Note [degenerate use of FFoldType] in TcGenGenerics.
939
940 Note [Generated code for DeriveFoldable and DeriveTraversable]
941 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
942 We adapt the algorithms for -XDeriveFoldable and -XDeriveTraversable based on
943 that of -XDeriveFunctor. However, there an important difference between deriving
944 the former two typeclasses and the latter one, which is best illustrated by the
945 following scenario:
946
947 data WithInt a = WithInt a Int# deriving (Functor, Foldable, Traversable)
948
949 The generated code for the Functor instance is straightforward:
950
951 instance Functor WithInt where
952 fmap f (WithInt a i) = WithInt (f a) i
953
954 But if we use too similar of a strategy for deriving the Foldable and
955 Traversable instances, we end up with this code:
956
957 instance Foldable WithInt where
958 foldMap f (WithInt a i) = f a <> mempty
959
960 instance Traversable WithInt where
961 traverse f (WithInt a i) = fmap WithInt (f a) <*> pure i
962
963 This is unsatisfying for two reasons:
964
965 1. The Traversable instance doesn't typecheck! Int# is of kind #, but pure
966 expects an argument whose type is of kind *. This effectively prevents
967 Traversable from being derived for any datatype with an unlifted argument
968 type (Trac #11174).
969
970 2. The generated code contains superfluous expressions. By the Monoid laws,
971 we can reduce (f a <> mempty) to (f a), and by the Applicative laws, we can
972 reduce (fmap WithInt (f a) <*> pure i) to (fmap (\b -> WithInt b i) (f a)).
973
974 We can fix both of these issues by incorporating a slight twist to the usual
975 algorithm that we use for -XDeriveFunctor. The differences can be summarized
976 as follows:
977
978 1. In the generated expression, we only fold over arguments whose types
979 mention the last type parameter. Any other argument types will simply
980 produce useless 'mempty's or 'pure's, so they can be safely ignored.
981
982 2. In the case of -XDeriveTraversable, instead of applying ConName,
983 we apply (\b_i ... b_k -> ConName a_1 ... a_n), where
984
985 * ConName has n arguments
986 * {b_i, ..., b_k} is a subset of {a_1, ..., a_n} whose indices correspond
987 to the arguments whose types mention the last type parameter. As a
988 consequence, taking the difference of {a_1, ..., a_n} and
989 {b_i, ..., b_k} yields the all the argument values of ConName whose types
990 do not mention the last type parameter. Note that [i, ..., k] is a
991 strictly increasing—but not necessarily consecutive—integer sequence.
992
993 For example, the datatype
994
995 data Foo a = Foo Int a Int a
996
997 would generate the following Traversable instance:
998
999 instance Traversable Foo where
1000 traverse f (Foo a1 a2 a3 a4) =
1001 fmap (\b2 b4 -> Foo a1 b2 a3 b4) (f a2) <*> f a4
1002
1003 Technically, this approach would also work for -XDeriveFunctor as well, but we
1004 decide not to do so because:
1005
1006 1. There's not much benefit to generating, e.g., ((\b -> WithInt b i) (f a))
1007 instead of (WithInt (f a) i).
1008
1009 2. There would be certain datatypes for which the above strategy would
1010 generate Functor code that would fail to typecheck. For example:
1011
1012 data Bar f a = Bar (forall f. Functor f => f a) deriving Functor
1013
1014 With the conventional algorithm, it would generate something like:
1015
1016 fmap f (Bar a) = Bar (fmap f a)
1017
1018 which typechecks. But with the strategy mentioned above, it would generate:
1019
1020 fmap f (Bar a) = (\b -> Bar b) (fmap f a)
1021
1022 which does not typecheck, since GHC cannot unify the rank-2 type variables
1023 in the types of b and (fmap f a).
1024 -}