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