Define mkTvSubst, and use it
[ghc.git] / compiler / typecheck / TcGenDeriv.hs
1 {-
2 %
3 (c) The University of Glasgow 2006
4 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
5
6
7 TcGenDeriv: Generating derived instance declarations
8
9 This module is nominally ``subordinate'' to @TcDeriv@, which is the
10 ``official'' interface to deriving-related things.
11
12 This is where we do all the grimy bindings' generation.
13 -}
14
15 {-# LANGUAGE CPP, ScopedTypeVariables #-}
16 {-# LANGUAGE FlexibleContexts #-}
17
18 module TcGenDeriv (
19 BagDerivStuff, DerivStuff(..),
20
21 hasBuiltinDeriving,
22 FFoldType(..), functorLikeTraverse,
23 deepSubtypesContaining, foldDataConArgs,
24 mkCoerceClassMethEqn,
25 gen_Newtype_binds,
26 genAuxBinds,
27 ordOpTbl, boxConTbl, litConTbl,
28 mkRdrFunBind
29 ) where
30
31 #include "HsVersions.h"
32
33 import HsSyn
34 import RdrName
35 import BasicTypes
36 import DataCon
37 import Name
38 import Fingerprint
39 import Encoding
40
41 import DynFlags
42 import PrelInfo
43 import FamInstEnv( FamInst )
44 import PrelNames
45 import THNames
46 import Module ( moduleName, moduleNameString
47 , moduleUnitId, unitIdString )
48 import MkId ( coerceId )
49 import PrimOp
50 import SrcLoc
51 import TyCon
52 import TcType
53 import TysPrim
54 import TysWiredIn
55 import Type
56 import Class
57 import TyCoRep
58 import VarSet
59 import VarEnv
60 import State
61 import Util
62 import Var
63 import Outputable
64 import Lexeme
65 import FastString
66 import Pair
67 import Bag
68 import TcEnv (InstInfo)
69 import StaticFlags( opt_PprStyle_Debug )
70
71 import ListSetOps ( assocMaybe )
72 import Data.List ( partition, intersperse )
73
74 type BagDerivStuff = Bag DerivStuff
75
76 data AuxBindSpec
77 = DerivCon2Tag TyCon -- The con2Tag for given TyCon
78 | DerivTag2Con TyCon -- ...ditto tag2Con
79 | DerivMaxTag TyCon -- ...and maxTag
80 deriving( Eq )
81 -- All these generate ZERO-BASED tag operations
82 -- I.e first constructor has tag 0
83
84 data DerivStuff -- Please add this auxiliary stuff
85 = DerivAuxBind AuxBindSpec
86
87 -- Generics
88 | DerivFamInst FamInst -- New type family instances
89
90 -- New top-level auxiliary bindings
91 | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB
92 | DerivInst (InstInfo RdrName) -- New, auxiliary instances
93
94 {-
95 ************************************************************************
96 * *
97 Class deriving diagnostics
98 * *
99 ************************************************************************
100
101 Only certain blessed classes can be used in a deriving clause. These classes
102 are listed below in the definition of hasBuiltinDeriving (with the exception
103 of Generic and Generic1, which are handled separately in TcGenGenerics).
104
105 A class might be able to be used in a deriving clause if it -XDeriveAnyClass
106 is willing to support it. The canDeriveAnyClass function checks if this is
107 the case.
108 -}
109
110 hasBuiltinDeriving :: DynFlags
111 -> (Name -> Fixity)
112 -> Class
113 -> Maybe (SrcSpan
114 -> TyCon
115 -> (LHsBinds RdrName, BagDerivStuff))
116 hasBuiltinDeriving dflags fix_env clas = assocMaybe gen_list (getUnique clas)
117 where
118 gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))]
119 gen_list = [ (eqClassKey, gen_Eq_binds)
120 , (ordClassKey, gen_Ord_binds)
121 , (enumClassKey, gen_Enum_binds)
122 , (boundedClassKey, gen_Bounded_binds)
123 , (ixClassKey, gen_Ix_binds)
124 , (showClassKey, gen_Show_binds fix_env)
125 , (readClassKey, gen_Read_binds fix_env)
126 , (dataClassKey, gen_Data_binds dflags)
127 , (functorClassKey, gen_Functor_binds)
128 , (foldableClassKey, gen_Foldable_binds)
129 , (traversableClassKey, gen_Traversable_binds)
130 , (liftClassKey, gen_Lift_binds) ]
131
132 {-
133 ************************************************************************
134 * *
135 Eq instances
136 * *
137 ************************************************************************
138
139 Here are the heuristics for the code we generate for @Eq@. Let's
140 assume we have a data type with some (possibly zero) nullary data
141 constructors and some ordinary, non-nullary ones (the rest, also
142 possibly zero of them). Here's an example, with both \tr{N}ullary and
143 \tr{O}rdinary data cons.
144
145 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
146
147 * For the ordinary constructors (if any), we emit clauses to do The
148 Usual Thing, e.g.,:
149
150 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
151 (==) (O2 a1) (O2 a2) = a1 == a2
152 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
153
154 Note: if we're comparing unlifted things, e.g., if 'a1' and
155 'a2' are Float#s, then we have to generate
156 case (a1 `eqFloat#` a2) of r -> r
157 for that particular test.
158
159 * If there are a lot of (more than en) nullary constructors, we emit a
160 catch-all clause of the form:
161
162 (==) a b = case (con2tag_Foo a) of { a# ->
163 case (con2tag_Foo b) of { b# ->
164 case (a# ==# b#) of {
165 r -> r }}}
166
167 If con2tag gets inlined this leads to join point stuff, so
168 it's better to use regular pattern matching if there aren't too
169 many nullary constructors. "Ten" is arbitrary, of course
170
171 * If there aren't any nullary constructors, we emit a simpler
172 catch-all:
173
174 (==) a b = False
175
176 * For the @(/=)@ method, we normally just use the default method.
177 If the type is an enumeration type, we could/may/should? generate
178 special code that calls @con2tag_Foo@, much like for @(==)@ shown
179 above.
180
181 We thought about doing this: If we're also deriving 'Ord' for this
182 tycon, we generate:
183 instance ... Eq (Foo ...) where
184 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
185 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
186 However, that requires that (Ord <whatever>) was put in the context
187 for the instance decl, which it probably wasn't, so the decls
188 produced don't get through the typechecker.
189 -}
190
191 gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
192 gen_Eq_binds loc tycon
193 = (method_binds, aux_binds)
194 where
195 all_cons = tyConDataCons tycon
196 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons
197
198 -- If there are ten or more (arbitrary number) nullary constructors,
199 -- use the con2tag stuff. For small types it's better to use
200 -- ordinary pattern matching.
201 (tag_match_cons, pat_match_cons)
202 | nullary_cons `lengthExceeds` 10 = (nullary_cons, non_nullary_cons)
203 | otherwise = ([], all_cons)
204
205 no_tag_match_cons = null tag_match_cons
206
207 fall_through_eqn
208 | no_tag_match_cons -- All constructors have arguments
209 = case pat_match_cons of
210 [] -> [] -- No constructors; no fall-though case
211 [_] -> [] -- One constructor; no fall-though case
212 _ -> -- Two or more constructors; add fall-through of
213 -- (==) _ _ = False
214 [([nlWildPat, nlWildPat], false_Expr)]
215
216 | otherwise -- One or more tag_match cons; add fall-through of
217 -- extract tags compare for equality
218 = [([a_Pat, b_Pat],
219 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
220 (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
221
222 aux_binds | no_tag_match_cons = emptyBag
223 | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
224
225 method_binds = listToBag [eq_bind, ne_bind]
226 eq_bind = mk_FunBind loc eq_RDR (map pats_etc pat_match_cons ++ fall_through_eqn)
227 ne_bind = mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
228 nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
229
230 ------------------------------------------------------------------
231 pats_etc data_con
232 = let
233 con1_pat = nlConVarPat data_con_RDR as_needed
234 con2_pat = nlConVarPat data_con_RDR bs_needed
235
236 data_con_RDR = getRdrName data_con
237 con_arity = length tys_needed
238 as_needed = take con_arity as_RDRs
239 bs_needed = take con_arity bs_RDRs
240 tys_needed = dataConOrigArgTys data_con
241 in
242 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
243 where
244 nested_eq_expr [] [] [] = true_Expr
245 nested_eq_expr tys as bs
246 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
247 where
248 nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
249
250 {-
251 ************************************************************************
252 * *
253 Ord instances
254 * *
255 ************************************************************************
256
257 Note [Generating Ord instances]
258 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
259 Suppose constructors are K1..Kn, and some are nullary.
260 The general form we generate is:
261
262 * Do case on first argument
263 case a of
264 K1 ... -> rhs_1
265 K2 ... -> rhs_2
266 ...
267 Kn ... -> rhs_n
268 _ -> nullary_rhs
269
270 * To make rhs_i
271 If i = 1, 2, n-1, n, generate a single case.
272 rhs_2 case b of
273 K1 {} -> LT
274 K2 ... -> ...eq_rhs(K2)...
275 _ -> GT
276
277 Otherwise do a tag compare against the bigger range
278 (because this is the one most likely to succeed)
279 rhs_3 case tag b of tb ->
280 if 3 <# tg then GT
281 else case b of
282 K3 ... -> ...eq_rhs(K3)....
283 _ -> LT
284
285 * To make eq_rhs(K), which knows that
286 a = K a1 .. av
287 b = K b1 .. bv
288 we just want to compare (a1,b1) then (a2,b2) etc.
289 Take care on the last field to tail-call into comparing av,bv
290
291 * To make nullary_rhs generate this
292 case con2tag a of a# ->
293 case con2tag b of ->
294 a# `compare` b#
295
296 Several special cases:
297
298 * Two or fewer nullary constructors: don't generate nullary_rhs
299
300 * Be careful about unlifted comparisons. When comparing unboxed
301 values we can't call the overloaded functions.
302 See function unliftedOrdOp
303
304 Note [Do not rely on compare]
305 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
306 It's a bad idea to define only 'compare', and build the other binary
307 comparisons on top of it; see Trac #2130, #4019. Reason: we don't
308 want to laboriously make a three-way comparison, only to extract a
309 binary result, something like this:
310 (>) (I# x) (I# y) = case <# x y of
311 True -> False
312 False -> case ==# x y of
313 True -> False
314 False -> True
315
316 So for sufficiently small types (few constructors, or all nullary)
317 we generate all methods; for large ones we just use 'compare'.
318 -}
319
320 data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT
321
322 ------------
323 ordMethRdr :: OrdOp -> RdrName
324 ordMethRdr op
325 = case op of
326 OrdCompare -> compare_RDR
327 OrdLT -> lt_RDR
328 OrdLE -> le_RDR
329 OrdGE -> ge_RDR
330 OrdGT -> gt_RDR
331
332 ------------
333 ltResult :: OrdOp -> LHsExpr RdrName
334 -- Knowing a<b, what is the result for a `op` b?
335 ltResult OrdCompare = ltTag_Expr
336 ltResult OrdLT = true_Expr
337 ltResult OrdLE = true_Expr
338 ltResult OrdGE = false_Expr
339 ltResult OrdGT = false_Expr
340
341 ------------
342 eqResult :: OrdOp -> LHsExpr RdrName
343 -- Knowing a=b, what is the result for a `op` b?
344 eqResult OrdCompare = eqTag_Expr
345 eqResult OrdLT = false_Expr
346 eqResult OrdLE = true_Expr
347 eqResult OrdGE = true_Expr
348 eqResult OrdGT = false_Expr
349
350 ------------
351 gtResult :: OrdOp -> LHsExpr RdrName
352 -- Knowing a>b, what is the result for a `op` b?
353 gtResult OrdCompare = gtTag_Expr
354 gtResult OrdLT = false_Expr
355 gtResult OrdLE = false_Expr
356 gtResult OrdGE = true_Expr
357 gtResult OrdGT = true_Expr
358
359 ------------
360 gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
361 gen_Ord_binds loc tycon
362 | null tycon_data_cons -- No data-cons => invoke bale-out case
363 = (unitBag $ mk_FunBind loc compare_RDR [], emptyBag)
364 | otherwise
365 = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
366 where
367 aux_binds | single_con_type = emptyBag
368 | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
369
370 -- Note [Do not rely on compare]
371 other_ops | (last_tag - first_tag) <= 2 -- 1-3 constructors
372 || null non_nullary_cons -- Or it's an enumeration
373 = listToBag (map mkOrdOp [OrdLT,OrdLE,OrdGE,OrdGT])
374 | otherwise
375 = emptyBag
376
377 get_tag con = dataConTag con - fIRST_TAG
378 -- We want *zero-based* tags, because that's what
379 -- con2Tag returns (generated by untag_Expr)!
380
381 tycon_data_cons = tyConDataCons tycon
382 single_con_type = isSingleton tycon_data_cons
383 (first_con : _) = tycon_data_cons
384 (last_con : _) = reverse tycon_data_cons
385 first_tag = get_tag first_con
386 last_tag = get_tag last_con
387
388 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
389
390
391 mkOrdOp :: OrdOp -> LHsBind RdrName
392 -- Returns a binding op a b = ... compares a and b according to op ....
393 mkOrdOp op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] (mkOrdOpRhs op)
394
395 mkOrdOpRhs :: OrdOp -> LHsExpr RdrName
396 mkOrdOpRhs op -- RHS for comparing 'a' and 'b' according to op
397 | length nullary_cons <= 2 -- Two nullary or fewer, so use cases
398 = nlHsCase (nlHsVar a_RDR) $
399 map (mkOrdOpAlt op) tycon_data_cons
400 -- i.e. case a of { C1 x y -> case b of C1 x y -> ....compare x,y...
401 -- C2 x -> case b of C2 x -> ....comopare x.... }
402
403 | null non_nullary_cons -- All nullary, so go straight to comparing tags
404 = mkTagCmp op
405
406 | otherwise -- Mixed nullary and non-nullary
407 = nlHsCase (nlHsVar a_RDR) $
408 (map (mkOrdOpAlt op) non_nullary_cons
409 ++ [mkSimpleHsAlt nlWildPat (mkTagCmp op)])
410
411
412 mkOrdOpAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
413 -- Make the alternative (Ki a1 a2 .. av ->
414 mkOrdOpAlt op data_con
415 = mkSimpleHsAlt (nlConVarPat data_con_RDR as_needed) (mkInnerRhs op data_con)
416 where
417 as_needed = take (dataConSourceArity data_con) as_RDRs
418 data_con_RDR = getRdrName data_con
419
420 mkInnerRhs op data_con
421 | single_con_type
422 = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ]
423
424 | tag == first_tag
425 = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
426 , mkSimpleHsAlt nlWildPat (ltResult op) ]
427 | tag == last_tag
428 = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
429 , mkSimpleHsAlt nlWildPat (gtResult op) ]
430
431 | tag == first_tag + 1
432 = nlHsCase (nlHsVar b_RDR) [ mkSimpleHsAlt (nlConWildPat first_con) (gtResult op)
433 , mkInnerEqAlt op data_con
434 , mkSimpleHsAlt nlWildPat (ltResult op) ]
435 | tag == last_tag - 1
436 = nlHsCase (nlHsVar b_RDR) [ mkSimpleHsAlt (nlConWildPat last_con) (ltResult op)
437 , mkInnerEqAlt op data_con
438 , mkSimpleHsAlt nlWildPat (gtResult op) ]
439
440 | tag > last_tag `div` 2 -- lower range is larger
441 = untag_Expr tycon [(b_RDR, bh_RDR)] $
442 nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
443 (gtResult op) $ -- Definitely GT
444 nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
445 , mkSimpleHsAlt nlWildPat (ltResult op) ]
446
447 | otherwise -- upper range is larger
448 = untag_Expr tycon [(b_RDR, bh_RDR)] $
449 nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
450 (ltResult op) $ -- Definitely LT
451 nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
452 , mkSimpleHsAlt nlWildPat (gtResult op) ]
453 where
454 tag = get_tag data_con
455 tag_lit = noLoc (HsLit (HsIntPrim "" (toInteger tag)))
456
457 mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
458 -- First argument 'a' known to be built with K
459 -- Returns a case alternative Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...)
460 mkInnerEqAlt op data_con
461 = mkSimpleHsAlt (nlConVarPat data_con_RDR bs_needed) $
462 mkCompareFields tycon op (dataConOrigArgTys data_con)
463 where
464 data_con_RDR = getRdrName data_con
465 bs_needed = take (dataConSourceArity data_con) bs_RDRs
466
467 mkTagCmp :: OrdOp -> LHsExpr RdrName
468 -- Both constructors known to be nullary
469 -- genreates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#
470 mkTagCmp op = untag_Expr tycon [(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $
471 unliftedOrdOp tycon intPrimTy op ah_RDR bh_RDR
472
473 mkCompareFields :: TyCon -> OrdOp -> [Type] -> LHsExpr RdrName
474 -- Generates nested comparisons for (a1,a2...) against (b1,b2,...)
475 -- where the ai,bi have the given types
476 mkCompareFields tycon op tys
477 = go tys as_RDRs bs_RDRs
478 where
479 go [] _ _ = eqResult op
480 go [ty] (a:_) (b:_)
481 | isUnliftedType ty = unliftedOrdOp tycon ty op a b
482 | otherwise = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)
483 go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
484 (ltResult op)
485 (go tys as bs)
486 (gtResult op)
487 go _ _ _ = panic "mkCompareFields"
488
489 -- (mk_compare ty a b) generates
490 -- (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })
491 -- but with suitable special cases for
492 mk_compare ty a b lt eq gt
493 | isUnliftedType ty
494 = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
495 | otherwise
496 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr))
497 [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) lt,
498 mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
499 mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gt]
500 where
501 a_expr = nlHsVar a
502 b_expr = nlHsVar b
503 (lt_op, _, eq_op, _, _) = primOrdOps "Ord" tycon ty
504
505 unliftedOrdOp :: TyCon -> Type -> OrdOp -> RdrName -> RdrName -> LHsExpr RdrName
506 unliftedOrdOp tycon ty op a b
507 = case op of
508 OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
509 ltTag_Expr eqTag_Expr gtTag_Expr
510 OrdLT -> wrap lt_op
511 OrdLE -> wrap le_op
512 OrdGE -> wrap ge_op
513 OrdGT -> wrap gt_op
514 where
515 (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" tycon ty
516 wrap prim_op = genPrimOpApp a_expr prim_op b_expr
517 a_expr = nlHsVar a
518 b_expr = nlHsVar b
519
520 unliftedCompare :: RdrName -> RdrName
521 -> LHsExpr RdrName -> LHsExpr RdrName -- What to cmpare
522 -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName -- Three results
523 -> LHsExpr RdrName
524 -- Return (if a < b then lt else if a == b then eq else gt)
525 unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
526 = nlHsIf (genPrimOpApp a_expr lt_op b_expr) lt $
527 -- Test (<) first, not (==), because the latter
528 -- is true less often, so putting it first would
529 -- mean more tests (dynamically)
530 nlHsIf (genPrimOpApp a_expr eq_op b_expr) eq gt
531
532 nlConWildPat :: DataCon -> LPat RdrName
533 -- The pattern (K {})
534 nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con))
535 (RecCon (HsRecFields { rec_flds = []
536 , rec_dotdot = Nothing })))
537
538 {-
539 ************************************************************************
540 * *
541 Enum instances
542 * *
543 ************************************************************************
544
545 @Enum@ can only be derived for enumeration types. For a type
546 \begin{verbatim}
547 data Foo ... = N1 | N2 | ... | Nn
548 \end{verbatim}
549
550 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
551 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
552
553 \begin{verbatim}
554 instance ... Enum (Foo ...) where
555 succ x = toEnum (1 + fromEnum x)
556 pred x = toEnum (fromEnum x - 1)
557
558 toEnum i = tag2con_Foo i
559
560 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
561
562 -- or, really...
563 enumFrom a
564 = case con2tag_Foo a of
565 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
566
567 enumFromThen a b
568 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
569
570 -- or, really...
571 enumFromThen a b
572 = case con2tag_Foo a of { a# ->
573 case con2tag_Foo b of { b# ->
574 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
575 }}
576 \end{verbatim}
577
578 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
579 -}
580
581 gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
582 gen_Enum_binds loc tycon
583 = (method_binds, aux_binds)
584 where
585 method_binds = listToBag [
586 succ_enum,
587 pred_enum,
588 to_enum,
589 enum_from,
590 enum_from_then,
591 from_enum
592 ]
593 aux_binds = listToBag $ map DerivAuxBind
594 [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
595
596 occ_nm = getOccString tycon
597
598 succ_enum
599 = mk_easy_FunBind loc succ_RDR [a_Pat] $
600 untag_Expr tycon [(a_RDR, ah_RDR)] $
601 nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
602 nlHsVarApps intDataCon_RDR [ah_RDR]])
603 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
604 (nlHsApp (nlHsVar (tag2con_RDR tycon))
605 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
606 nlHsIntLit 1]))
607
608 pred_enum
609 = mk_easy_FunBind loc pred_RDR [a_Pat] $
610 untag_Expr tycon [(a_RDR, ah_RDR)] $
611 nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
612 nlHsVarApps intDataCon_RDR [ah_RDR]])
613 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
614 (nlHsApp (nlHsVar (tag2con_RDR tycon))
615 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
616 nlHsLit (HsInt "-1" (-1))]))
617
618 to_enum
619 = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
620 nlHsIf (nlHsApps and_RDR
621 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
622 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
623 (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
624 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
625
626 enum_from
627 = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
628 untag_Expr tycon [(a_RDR, ah_RDR)] $
629 nlHsApps map_RDR
630 [nlHsVar (tag2con_RDR tycon),
631 nlHsPar (enum_from_to_Expr
632 (nlHsVarApps intDataCon_RDR [ah_RDR])
633 (nlHsVar (maxtag_RDR tycon)))]
634
635 enum_from_then
636 = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
637 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
638 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
639 nlHsPar (enum_from_then_to_Expr
640 (nlHsVarApps intDataCon_RDR [ah_RDR])
641 (nlHsVarApps intDataCon_RDR [bh_RDR])
642 (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
643 nlHsVarApps intDataCon_RDR [bh_RDR]])
644 (nlHsIntLit 0)
645 (nlHsVar (maxtag_RDR tycon))
646 ))
647
648 from_enum
649 = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
650 untag_Expr tycon [(a_RDR, ah_RDR)] $
651 (nlHsVarApps intDataCon_RDR [ah_RDR])
652
653 {-
654 ************************************************************************
655 * *
656 Bounded instances
657 * *
658 ************************************************************************
659 -}
660
661 gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
662 gen_Bounded_binds loc tycon
663 | isEnumerationTyCon tycon
664 = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
665 | otherwise
666 = ASSERT(isSingleton data_cons)
667 (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)
668 where
669 data_cons = tyConDataCons tycon
670
671 ----- enum-flavored: ---------------------------
672 min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
673 max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
674
675 data_con_1 = head data_cons
676 data_con_N = last data_cons
677 data_con_1_RDR = getRdrName data_con_1
678 data_con_N_RDR = getRdrName data_con_N
679
680 ----- single-constructor-flavored: -------------
681 arity = dataConSourceArity data_con_1
682
683 min_bound_1con = mkHsVarBind loc minBound_RDR $
684 nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
685 max_bound_1con = mkHsVarBind loc maxBound_RDR $
686 nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
687
688 {-
689 ************************************************************************
690 * *
691 Ix instances
692 * *
693 ************************************************************************
694
695 Deriving @Ix@ is only possible for enumeration types and
696 single-constructor types. We deal with them in turn.
697
698 For an enumeration type, e.g.,
699 \begin{verbatim}
700 data Foo ... = N1 | N2 | ... | Nn
701 \end{verbatim}
702 things go not too differently from @Enum@:
703 \begin{verbatim}
704 instance ... Ix (Foo ...) where
705 range (a, b)
706 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
707
708 -- or, really...
709 range (a, b)
710 = case (con2tag_Foo a) of { a# ->
711 case (con2tag_Foo b) of { b# ->
712 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
713 }}
714
715 -- Generate code for unsafeIndex, because using index leads
716 -- to lots of redundant range tests
717 unsafeIndex c@(a, b) d
718 = case (con2tag_Foo d -# con2tag_Foo a) of
719 r# -> I# r#
720
721 inRange (a, b) c
722 = let
723 p_tag = con2tag_Foo c
724 in
725 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
726
727 -- or, really...
728 inRange (a, b) c
729 = case (con2tag_Foo a) of { a_tag ->
730 case (con2tag_Foo b) of { b_tag ->
731 case (con2tag_Foo c) of { c_tag ->
732 if (c_tag >=# a_tag) then
733 c_tag <=# b_tag
734 else
735 False
736 }}}
737 \end{verbatim}
738 (modulo suitable case-ification to handle the unlifted tags)
739
740 For a single-constructor type (NB: this includes all tuples), e.g.,
741 \begin{verbatim}
742 data Foo ... = MkFoo a b Int Double c c
743 \end{verbatim}
744 we follow the scheme given in Figure~19 of the Haskell~1.2 report
745 (p.~147).
746 -}
747
748 gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
749
750 gen_Ix_binds loc tycon
751 | isEnumerationTyCon tycon
752 = ( enum_ixes
753 , listToBag $ map DerivAuxBind
754 [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
755 | otherwise
756 = (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))
757 where
758 --------------------------------------------------------------
759 enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
760
761 enum_range
762 = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
763 untag_Expr tycon [(a_RDR, ah_RDR)] $
764 untag_Expr tycon [(b_RDR, bh_RDR)] $
765 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
766 nlHsPar (enum_from_to_Expr
767 (nlHsVarApps intDataCon_RDR [ah_RDR])
768 (nlHsVarApps intDataCon_RDR [bh_RDR]))
769
770 enum_index
771 = mk_easy_FunBind loc unsafeIndex_RDR
772 [noLoc (AsPat (noLoc c_RDR)
773 (nlTuplePat [a_Pat, nlWildPat] Boxed)),
774 d_Pat] (
775 untag_Expr tycon [(a_RDR, ah_RDR)] (
776 untag_Expr tycon [(d_RDR, dh_RDR)] (
777 let
778 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
779 in
780 nlHsCase
781 (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
782 [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
783 ))
784 )
785
786 -- This produces something like `(ch >= ah) && (ch <= bh)`
787 enum_inRange
788 = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
789 untag_Expr tycon [(a_RDR, ah_RDR)] (
790 untag_Expr tycon [(b_RDR, bh_RDR)] (
791 untag_Expr tycon [(c_RDR, ch_RDR)] (
792 -- This used to use `if`, which interacts badly with RebindableSyntax.
793 -- See #11396.
794 nlHsApps and_RDR
795 [ genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)
796 , genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR)
797 ]
798 )))
799
800 --------------------------------------------------------------
801 single_con_ixes
802 = listToBag [single_con_range, single_con_index, single_con_inRange]
803
804 data_con
805 = case tyConSingleDataCon_maybe tycon of -- just checking...
806 Nothing -> panic "get_Ix_binds"
807 Just dc -> dc
808
809 con_arity = dataConSourceArity data_con
810 data_con_RDR = getRdrName data_con
811
812 as_needed = take con_arity as_RDRs
813 bs_needed = take con_arity bs_RDRs
814 cs_needed = take con_arity cs_RDRs
815
816 con_pat xs = nlConVarPat data_con_RDR xs
817 con_expr = nlHsVarApps data_con_RDR cs_needed
818
819 --------------------------------------------------------------
820 single_con_range
821 = mk_easy_FunBind loc range_RDR
822 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
823 noLoc (mkHsComp ListComp stmts con_expr)
824 where
825 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
826
827 mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
828 (nlHsApp (nlHsVar range_RDR)
829 (mkLHsVarTuple [a,b]))
830
831 ----------------
832 single_con_index
833 = mk_easy_FunBind loc unsafeIndex_RDR
834 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
835 con_pat cs_needed]
836 -- We need to reverse the order we consider the components in
837 -- so that
838 -- range (l,u) !! index (l,u) i == i -- when i is in range
839 -- (from http://haskell.org/onlinereport/ix.html) holds.
840 (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
841 where
842 -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
843 mk_index [] = nlHsIntLit 0
844 mk_index [(l,u,i)] = mk_one l u i
845 mk_index ((l,u,i) : rest)
846 = genOpApp (
847 mk_one l u i
848 ) plus_RDR (
849 genOpApp (
850 (nlHsApp (nlHsVar unsafeRangeSize_RDR)
851 (mkLHsVarTuple [l,u]))
852 ) times_RDR (mk_index rest)
853 )
854 mk_one l u i
855 = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i]
856
857 ------------------
858 single_con_inRange
859 = mk_easy_FunBind loc inRange_RDR
860 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
861 con_pat cs_needed] $
862 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
863 where
864 in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
865
866 {-
867 ************************************************************************
868 * *
869 Read instances
870 * *
871 ************************************************************************
872
873 Example
874
875 infix 4 %%
876 data T = Int %% Int
877 | T1 { f1 :: Int }
878 | T2 T
879
880 instance Read T where
881 readPrec =
882 parens
883 ( prec 4 (
884 do x <- ReadP.step Read.readPrec
885 expectP (Symbol "%%")
886 y <- ReadP.step Read.readPrec
887 return (x %% y))
888 +++
889 prec (appPrec+1) (
890 -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
891 -- Record construction binds even more tightly than application
892 do expectP (Ident "T1")
893 expectP (Punc '{')
894 expectP (Ident "f1")
895 expectP (Punc '=')
896 x <- ReadP.reset Read.readPrec
897 expectP (Punc '}')
898 return (T1 { f1 = x }))
899 +++
900 prec appPrec (
901 do expectP (Ident "T2")
902 x <- ReadP.step Read.readPrec
903 return (T2 x))
904 )
905
906 readListPrec = readListPrecDefault
907 readList = readListDefault
908
909
910 Note [Use expectP]
911 ~~~~~~~~~~~~~~~~~~
912 Note that we use
913 expectP (Ident "T1")
914 rather than
915 Ident "T1" <- lexP
916 The latter desugares to inline code for matching the Ident and the
917 string, and this can be very voluminous. The former is much more
918 compact. Cf Trac #7258, although that also concerned non-linearity in
919 the occurrence analyser, a separate issue.
920
921 Note [Read for empty data types]
922 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
923 What should we get for this? (Trac #7931)
924 data Emp deriving( Read ) -- No data constructors
925
926 Here we want
927 read "[]" :: [Emp] to succeed, returning []
928 So we do NOT want
929 instance Read Emp where
930 readPrec = error "urk"
931 Rather we want
932 instance Read Emp where
933 readPred = pfail -- Same as choose []
934
935 Because 'pfail' allows the parser to backtrack, but 'error' doesn't.
936 These instances are also useful for Read (Either Int Emp), where
937 we want to be able to parse (Left 3) just fine.
938 -}
939
940 gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
941
942 gen_Read_binds get_fixity loc tycon
943 = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
944 where
945 -----------------------------------------------------------------------
946 default_readlist
947 = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
948
949 default_readlistprec
950 = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
951 -----------------------------------------------------------------------
952
953 data_cons = tyConDataCons tycon
954 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
955
956 read_prec = mkHsVarBind loc readPrec_RDR
957 (nlHsApp (nlHsVar parens_RDR) read_cons)
958
959 read_cons | null data_cons = nlHsVar pfail_RDR -- See Note [Read for empty data types]
960 | otherwise = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
961 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
962
963 read_nullary_cons
964 = case nullary_cons of
965 [] -> []
966 [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])]
967 _ -> [nlHsApp (nlHsVar choose_RDR)
968 (nlList (map mk_pair nullary_cons))]
969 -- NB For operators the parens around (:=:) are matched by the
970 -- enclosing "parens" call, so here we must match the naked
971 -- data_con_str con
972
973 match_con con | isSym con_str = [symbol_pat con_str]
974 | otherwise = ident_h_pat con_str
975 where
976 con_str = data_con_str con
977 -- For nullary constructors we must match Ident s for normal constrs
978 -- and Symbol s for operators
979
980 mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),
981 result_expr con []]
982
983 read_non_nullary_con data_con
984 | is_infix = mk_parser infix_prec infix_stmts body
985 | is_record = mk_parser record_prec record_stmts body
986 -- Using these two lines instead allows the derived
987 -- read for infix and record bindings to read the prefix form
988 -- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body)
989 -- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
990 | otherwise = prefix_parser
991 where
992 body = result_expr data_con as_needed
993 con_str = data_con_str data_con
994
995 prefix_parser = mk_parser prefix_prec prefix_stmts body
996
997 read_prefix_con
998 | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"]
999 | otherwise = ident_h_pat con_str
1000
1001 read_infix_con
1002 | isSym con_str = [symbol_pat con_str]
1003 | otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"]
1004
1005 prefix_stmts -- T a b c
1006 = read_prefix_con ++ read_args
1007
1008 infix_stmts -- a %% b, or a `T` b
1009 = [read_a1]
1010 ++ read_infix_con
1011 ++ [read_a2]
1012
1013 record_stmts -- T { f1 = a, f2 = b }
1014 = read_prefix_con
1015 ++ [read_punc "{"]
1016 ++ concat (intersperse [read_punc ","] field_stmts)
1017 ++ [read_punc "}"]
1018
1019 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
1020
1021 con_arity = dataConSourceArity data_con
1022 labels = map flLabel $ dataConFieldLabels data_con
1023 dc_nm = getName data_con
1024 is_infix = dataConIsInfix data_con
1025 is_record = length labels > 0
1026 as_needed = take con_arity as_RDRs
1027 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
1028 (read_a1:read_a2:_) = read_args
1029
1030 prefix_prec = appPrecedence
1031 infix_prec = getPrecedence get_fixity dc_nm
1032 record_prec = appPrecedence + 1 -- Record construction binds even more tightly
1033 -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
1034
1035 ------------------------------------------------------------------------
1036 -- Helpers
1037 ------------------------------------------------------------------------
1038 mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
1039 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b })
1040 , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])]
1041 con_app con as = nlHsVarApps (getRdrName con) as -- con as
1042 result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
1043
1044 -- For constructors and field labels ending in '#', we hackily
1045 -- let the lexer generate two tokens, and look for both in sequence
1046 -- Thus [Ident "I"; Symbol "#"]. See Trac #5041
1047 ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ]
1048 | otherwise = [ ident_pat s ]
1049
1050 bindLex pat = noLoc (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat)) -- expectP p
1051 -- See Note [Use expectP]
1052 ident_pat s = bindLex $ nlHsApps ident_RDR [nlHsLit (mkHsString s)] -- expectP (Ident "foo")
1053 symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)] -- expectP (Symbol ">>")
1054 read_punc c = bindLex $ nlHsApps punc_RDR [nlHsLit (mkHsString c)] -- expectP (Punc "<")
1055
1056 data_con_str con = occNameString (getOccName con)
1057
1058 read_arg a ty = ASSERT( not (isUnliftedType ty) )
1059 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
1060
1061 read_field lbl a = read_lbl lbl ++
1062 [read_punc "=",
1063 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
1064
1065 -- When reading field labels we might encounter
1066 -- a = 3
1067 -- _a = 3
1068 -- or (#) = 4
1069 -- Note the parens!
1070 read_lbl lbl | isSym lbl_str
1071 = [read_punc "(", symbol_pat lbl_str, read_punc ")"]
1072 | otherwise
1073 = ident_h_pat lbl_str
1074 where
1075 lbl_str = unpackFS lbl
1076
1077 {-
1078 ************************************************************************
1079 * *
1080 Show instances
1081 * *
1082 ************************************************************************
1083
1084 Example
1085
1086 infixr 5 :^:
1087
1088 data Tree a = Leaf a | Tree a :^: Tree a
1089
1090 instance (Show a) => Show (Tree a) where
1091
1092 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
1093 where
1094 showStr = showString "Leaf " . showsPrec (app_prec+1) m
1095
1096 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
1097 where
1098 showStr = showsPrec (up_prec+1) u .
1099 showString " :^: " .
1100 showsPrec (up_prec+1) v
1101 -- Note: right-associativity of :^: ignored
1102
1103 up_prec = 5 -- Precedence of :^:
1104 app_prec = 10 -- Application has precedence one more than
1105 -- the most tightly-binding operator
1106 -}
1107
1108 gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1109
1110 gen_Show_binds get_fixity loc tycon
1111 = (listToBag [shows_prec, show_list], emptyBag)
1112 where
1113 -----------------------------------------------------------------------
1114 show_list = mkHsVarBind loc showList_RDR
1115 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
1116 -----------------------------------------------------------------------
1117 data_cons = tyConDataCons tycon
1118 shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc data_cons)
1119
1120 pats_etc data_con
1121 | nullary_con = -- skip the showParen junk...
1122 ASSERT(null bs_needed)
1123 ([nlWildPat, con_pat], mk_showString_app op_con_str)
1124 | record_syntax = -- skip showParen (#2530)
1125 ([a_Pat, con_pat], nlHsPar (nested_compose_Expr show_thingies))
1126 | otherwise =
1127 ([a_Pat, con_pat],
1128 showParen_Expr (genOpApp a_Expr ge_RDR
1129 (nlHsLit (HsInt "" con_prec_plus_one)))
1130 (nlHsPar (nested_compose_Expr show_thingies)))
1131 where
1132 data_con_RDR = getRdrName data_con
1133 con_arity = dataConSourceArity data_con
1134 bs_needed = take con_arity bs_RDRs
1135 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
1136 con_pat = nlConVarPat data_con_RDR bs_needed
1137 nullary_con = con_arity == 0
1138 labels = map flLabel $ dataConFieldLabels data_con
1139 lab_fields = length labels
1140 record_syntax = lab_fields > 0
1141
1142 dc_nm = getName data_con
1143 dc_occ_nm = getOccName data_con
1144 con_str = occNameString dc_occ_nm
1145 op_con_str = wrapOpParens con_str
1146 backquote_str = wrapOpBackquotes con_str
1147
1148 show_thingies
1149 | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
1150 | record_syntax = mk_showString_app (op_con_str ++ " {") :
1151 show_record_args ++ [mk_showString_app "}"]
1152 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
1153
1154 show_label l = mk_showString_app (nm ++ " = ")
1155 -- Note the spaces around the "=" sign. If we
1156 -- don't have them then we get Foo { x=-1 } and
1157 -- the "=-" parses as a single lexeme. Only the
1158 -- space after the '=' is necessary, but it
1159 -- seems tidier to have them both sides.
1160 where
1161 nm = wrapOpParens (unpackFS l)
1162
1163 show_args = zipWith show_arg bs_needed arg_tys
1164 (show_arg1:show_arg2:_) = show_args
1165 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
1166
1167 -- Assumption for record syntax: no of fields == no of
1168 -- labelled fields (and in same order)
1169 show_record_args = concat $
1170 intersperse [mk_showString_app ", "] $
1171 [ [show_label lbl, arg]
1172 | (lbl,arg) <- zipEqual "gen_Show_binds"
1173 labels show_args ]
1174
1175 show_arg :: RdrName -> Type -> LHsExpr RdrName
1176 show_arg b arg_ty
1177 | isUnliftedType arg_ty
1178 -- See Note [Deriving and unboxed types] in TcDeriv
1179 = nlHsApps compose_RDR [mk_shows_app boxed_arg,
1180 mk_showString_app postfixMod]
1181 | otherwise
1182 = mk_showsPrec_app arg_prec arg
1183 where
1184 arg = nlHsVar b
1185 boxed_arg = box "Show" tycon arg arg_ty
1186 postfixMod = assoc_ty_id "Show" tycon postfixModTbl arg_ty
1187
1188 -- Fixity stuff
1189 is_infix = dataConIsInfix data_con
1190 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1191 arg_prec | record_syntax = 0 -- Record fields don't need parens
1192 | otherwise = con_prec_plus_one
1193
1194 wrapOpParens :: String -> String
1195 wrapOpParens s | isSym s = '(' : s ++ ")"
1196 | otherwise = s
1197
1198 wrapOpBackquotes :: String -> String
1199 wrapOpBackquotes s | isSym s = s
1200 | otherwise = '`' : s ++ "`"
1201
1202 isSym :: String -> Bool
1203 isSym "" = False
1204 isSym (c : _) = startsVarSym c || startsConSym c
1205
1206 -- | showString :: String -> ShowS
1207 mk_showString_app :: String -> LHsExpr RdrName
1208 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1209
1210 -- | showsPrec :: Show a => Int -> a -> ShowS
1211 mk_showsPrec_app :: Integer -> LHsExpr RdrName -> LHsExpr RdrName
1212 mk_showsPrec_app p x = nlHsApps showsPrec_RDR [nlHsLit (HsInt "" p), x]
1213
1214 -- | shows :: Show a => a -> ShowS
1215 mk_shows_app :: LHsExpr RdrName -> LHsExpr RdrName
1216 mk_shows_app x = nlHsApp (nlHsVar shows_RDR) x
1217
1218 getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer
1219 getPrec is_infix get_fixity nm
1220 | not is_infix = appPrecedence
1221 | otherwise = getPrecedence get_fixity nm
1222
1223 appPrecedence :: Integer
1224 appPrecedence = fromIntegral maxPrecedence + 1
1225 -- One more than the precedence of the most
1226 -- tightly-binding operator
1227
1228 getPrecedence :: (Name -> Fixity) -> Name -> Integer
1229 getPrecedence get_fixity nm
1230 = case get_fixity nm of
1231 Fixity _ x _assoc -> fromIntegral x
1232 -- NB: the Report says that associativity is not taken
1233 -- into account for either Read or Show; hence we
1234 -- ignore associativity here
1235
1236 {-
1237 ************************************************************************
1238 * *
1239 Data instances
1240 * *
1241 ************************************************************************
1242
1243 From the data type
1244
1245 data T a b = T1 a b | T2
1246
1247 we generate
1248
1249 $cT1 = mkDataCon $dT "T1" Prefix
1250 $cT2 = mkDataCon $dT "T2" Prefix
1251 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1252 -- the [] is for field labels.
1253
1254 instance (Data a, Data b) => Data (T a b) where
1255 gfoldl k z (T1 a b) = z T `k` a `k` b
1256 gfoldl k z T2 = z T2
1257 -- ToDo: add gmapT,Q,M, gfoldr
1258
1259 gunfold k z c = case conIndex c of
1260 I# 1# -> k (k (z T1))
1261 I# 2# -> z T2
1262
1263 toConstr (T1 _ _) = $cT1
1264 toConstr T2 = $cT2
1265
1266 dataTypeOf _ = $dT
1267
1268 dataCast1 = gcast1 -- If T :: * -> *
1269 dataCast2 = gcast2 -- if T :: * -> * -> *
1270 -}
1271
1272 gen_Data_binds :: DynFlags
1273 -> SrcSpan
1274 -> TyCon -- For data families, this is the
1275 -- *representation* TyCon
1276 -> (LHsBinds RdrName, -- The method bindings
1277 BagDerivStuff) -- Auxiliary bindings
1278 gen_Data_binds dflags loc rep_tc
1279 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
1280 `unionBags` gcast_binds,
1281 -- Auxiliary definitions: the data type and constructors
1282 listToBag ( DerivHsBind (genDataTyCon)
1283 : map (DerivHsBind . genDataDataCon) data_cons))
1284 where
1285 data_cons = tyConDataCons rep_tc
1286 n_cons = length data_cons
1287 one_constr = n_cons == 1
1288
1289 genDataTyCon :: (LHsBind RdrName, LSig RdrName)
1290 genDataTyCon -- $dT
1291 = (mkHsVarBind loc rdr_name rhs,
1292 L loc (TypeSig [L loc rdr_name] sig_ty))
1293 where
1294 rdr_name = mk_data_type_name rep_tc
1295 sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR)
1296 constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons rep_tc]
1297 rhs = nlHsVar mkDataType_RDR
1298 `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc)))
1299 `nlHsApp` nlList constrs
1300
1301 genDataDataCon :: DataCon -> (LHsBind RdrName, LSig RdrName)
1302 genDataDataCon dc -- $cT1 etc
1303 = (mkHsVarBind loc rdr_name rhs,
1304 L loc (TypeSig [L loc rdr_name] sig_ty))
1305 where
1306 rdr_name = mk_constr_name dc
1307 sig_ty = mkLHsSigWcType (nlHsTyVar constr_RDR)
1308 rhs = nlHsApps mkConstr_RDR constr_args
1309
1310 constr_args
1311 = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1312 nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
1313 nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1314 nlList labels, -- Field labels
1315 nlHsVar fixity] -- Fixity
1316
1317 labels = map (nlHsLit . mkHsString . unpackFS . flLabel)
1318 (dataConFieldLabels dc)
1319 dc_occ = getOccName dc
1320 is_infix = isDataSymOcc dc_occ
1321 fixity | is_infix = infix_RDR
1322 | otherwise = prefix_RDR
1323
1324 ------------ gfoldl
1325 gfoldl_bind = mk_HRFunBind 2 loc gfoldl_RDR (map gfoldl_eqn data_cons)
1326
1327 gfoldl_eqn con
1328 = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1329 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1330 where
1331 con_name :: RdrName
1332 con_name = getRdrName con
1333 as_needed = take (dataConSourceArity con) as_RDRs
1334 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1335
1336 ------------ gunfold
1337 gunfold_bind = mk_HRFunBind 2 loc
1338 gunfold_RDR
1339 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1340 gunfold_rhs)]
1341
1342 gunfold_rhs
1343 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1344 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1345 (map gunfold_alt data_cons)
1346
1347 gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1348 mk_unfold_rhs dc = foldr nlHsApp
1349 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1350 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1351
1352 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1353 -- redundant test, and annoying warning
1354 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1355 | otherwise = nlConPat intDataCon_RDR
1356 [nlLitPat (HsIntPrim "" (toInteger tag))]
1357 where
1358 tag = dataConTag dc
1359
1360 ------------ toConstr
1361 toCon_bind = mk_FunBind loc toConstr_RDR (map to_con_eqn data_cons)
1362 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1363
1364 ------------ dataTypeOf
1365 dataTypeOf_bind = mk_easy_FunBind
1366 loc
1367 dataTypeOf_RDR
1368 [nlWildPat]
1369 (nlHsVar (mk_data_type_name rep_tc))
1370
1371 ------------ gcast1/2
1372 -- Make the binding dataCast1 x = gcast1 x -- if T :: * -> *
1373 -- or dataCast2 x = gcast2 s -- if T :: * -> * -> *
1374 -- (or nothing if T has neither of these two types)
1375
1376 -- But care is needed for data families:
1377 -- If we have data family D a
1378 -- data instance D (a,b,c) = A | B deriving( Data )
1379 -- and we want instance ... => Data (D [(a,b,c)]) where ...
1380 -- then we need dataCast1 x = gcast1 x
1381 -- because D :: * -> *
1382 -- even though rep_tc has kind * -> * -> * -> *
1383 -- Hence looking for the kind of fam_tc not rep_tc
1384 -- See Trac #4896
1385 tycon_kind = case tyConFamInst_maybe rep_tc of
1386 Just (fam_tc, _) -> tyConKind fam_tc
1387 Nothing -> tyConKind rep_tc
1388 gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR
1389 | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
1390 | otherwise = emptyBag
1391 mk_gcast dataCast_RDR gcast_RDR
1392 = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
1393 (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
1394
1395
1396 kind1, kind2 :: Kind
1397 kind1 = liftedTypeKind `mkFunTy` liftedTypeKind
1398 kind2 = liftedTypeKind `mkFunTy` kind1
1399
1400 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
1401 mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
1402 dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,
1403 constr_RDR, dataType_RDR,
1404 eqChar_RDR , ltChar_RDR , geChar_RDR , gtChar_RDR , leChar_RDR ,
1405 eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR ,
1406 eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR ,
1407 eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR ,
1408 eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,
1409 eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR :: RdrName
1410 gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
1411 gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
1412 toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
1413 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1414 dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1")
1415 dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2")
1416 gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1")
1417 gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2")
1418 mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
1419 constr_RDR = tcQual_RDR gENERICS (fsLit "Constr")
1420 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1421 dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType")
1422 conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
1423 prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix")
1424 infix_RDR = dataQual_RDR gENERICS (fsLit "Infix")
1425
1426 eqChar_RDR = varQual_RDR gHC_PRIM (fsLit "eqChar#")
1427 ltChar_RDR = varQual_RDR gHC_PRIM (fsLit "ltChar#")
1428 leChar_RDR = varQual_RDR gHC_PRIM (fsLit "leChar#")
1429 gtChar_RDR = varQual_RDR gHC_PRIM (fsLit "gtChar#")
1430 geChar_RDR = varQual_RDR gHC_PRIM (fsLit "geChar#")
1431
1432 eqInt_RDR = varQual_RDR gHC_PRIM (fsLit "==#")
1433 ltInt_RDR = varQual_RDR gHC_PRIM (fsLit "<#" )
1434 leInt_RDR = varQual_RDR gHC_PRIM (fsLit "<=#")
1435 gtInt_RDR = varQual_RDR gHC_PRIM (fsLit ">#" )
1436 geInt_RDR = varQual_RDR gHC_PRIM (fsLit ">=#")
1437
1438 eqWord_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord#")
1439 ltWord_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord#")
1440 leWord_RDR = varQual_RDR gHC_PRIM (fsLit "leWord#")
1441 gtWord_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord#")
1442 geWord_RDR = varQual_RDR gHC_PRIM (fsLit "geWord#")
1443
1444 eqAddr_RDR = varQual_RDR gHC_PRIM (fsLit "eqAddr#")
1445 ltAddr_RDR = varQual_RDR gHC_PRIM (fsLit "ltAddr#")
1446 leAddr_RDR = varQual_RDR gHC_PRIM (fsLit "leAddr#")
1447 gtAddr_RDR = varQual_RDR gHC_PRIM (fsLit "gtAddr#")
1448 geAddr_RDR = varQual_RDR gHC_PRIM (fsLit "geAddr#")
1449
1450 eqFloat_RDR = varQual_RDR gHC_PRIM (fsLit "eqFloat#")
1451 ltFloat_RDR = varQual_RDR gHC_PRIM (fsLit "ltFloat#")
1452 leFloat_RDR = varQual_RDR gHC_PRIM (fsLit "leFloat#")
1453 gtFloat_RDR = varQual_RDR gHC_PRIM (fsLit "gtFloat#")
1454 geFloat_RDR = varQual_RDR gHC_PRIM (fsLit "geFloat#")
1455
1456 eqDouble_RDR = varQual_RDR gHC_PRIM (fsLit "==##")
1457 ltDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<##" )
1458 leDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<=##")
1459 gtDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">##" )
1460 geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##")
1461
1462 {-
1463 ************************************************************************
1464 * *
1465 Functor instances
1466
1467 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1468
1469 * *
1470 ************************************************************************
1471
1472 For the data type:
1473
1474 data T a = T1 Int a | T2 (T a)
1475
1476 We generate the instance:
1477
1478 instance Functor T where
1479 fmap f (T1 b1 a) = T1 b1 (f a)
1480 fmap f (T2 ta) = T2 (fmap f ta)
1481
1482 Notice that we don't simply apply 'fmap' to the constructor arguments.
1483 Rather
1484 - Do nothing to an argument whose type doesn't mention 'a'
1485 - Apply 'f' to an argument of type 'a'
1486 - Apply 'fmap f' to other arguments
1487 That's why we have to recurse deeply into the constructor argument types,
1488 rather than just one level, as we typically do.
1489
1490 What about types with more than one type parameter? In general, we only
1491 derive Functor for the last position:
1492
1493 data S a b = S1 [b] | S2 (a, T a b)
1494 instance Functor (S a) where
1495 fmap f (S1 bs) = S1 (fmap f bs)
1496 fmap f (S2 (p,q)) = S2 (a, fmap f q)
1497
1498 However, we have special cases for
1499 - tuples
1500 - functions
1501
1502 More formally, we write the derivation of fmap code over type variable
1503 'a for type 'b as ($fmap 'a 'b). In this general notation the derived
1504 instance for T is:
1505
1506 instance Functor T where
1507 fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
1508 fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1)
1509
1510 $(fmap 'a 'b) = \x -> x -- when b does not contain a
1511 $(fmap 'a 'a) = f
1512 $(fmap 'a '(b1,b2)) = \x -> case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
1513 $(fmap 'a '(T b1 b2)) = fmap $(fmap 'a 'b2) -- when a only occurs in the last parameter, b2
1514 $(fmap 'a '(b -> c)) = \x b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
1515
1516 For functions, the type parameter 'a can occur in a contravariant position,
1517 which means we need to derive a function like:
1518
1519 cofmap :: (a -> b) -> (f b -> f a)
1520
1521 This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
1522
1523 $(cofmap 'a 'b) = \x -> x -- when b does not contain a
1524 $(cofmap 'a 'a) = error "type variable in contravariant position"
1525 $(cofmap 'a '(b1,b2)) = \x -> case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
1526 $(cofmap 'a '[b]) = map $(cofmap 'a 'b)
1527 $(cofmap 'a '(T b1 b2)) = fmap $(cofmap 'a 'b2) -- when a only occurs in the last parameter, b2
1528 $(cofmap 'a '(b -> c)) = \x b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
1529
1530 Note that the code produced by $(fmap _ _) is always a higher order function,
1531 with type `(a -> b) -> (g a -> g b)` for some g. When we need to do pattern
1532 matching on the type, this means create a lambda function (see the (,) case above).
1533 The resulting code for fmap can look a bit weird, for example:
1534
1535 data X a = X (a,Int)
1536 -- generated instance
1537 instance Functor X where
1538 fmap f (X x) = (\y -> case y of (x1,x2) -> X (f x1, (\z -> z) x2)) x
1539
1540 The optimizer should be able to simplify this code by simple inlining.
1541
1542 An older version of the deriving code tried to avoid these applied
1543 lambda functions by producing a meta level function. But the function to
1544 be mapped, `f`, is a function on the code level, not on the meta level,
1545 so it was eta expanded to `\x -> [| f $x |]`. This resulted in too much eta expansion.
1546 It is better to produce too many lambdas than to eta expand, see ticket #7436.
1547 -}
1548
1549 gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1550 gen_Functor_binds loc tycon
1551 = (unitBag fmap_bind, emptyBag)
1552 where
1553 data_cons = tyConDataCons tycon
1554 fmap_bind = mkRdrFunBind (L loc fmap_RDR) eqns
1555
1556 fmap_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
1557 where
1558 parts = sequence $ foldDataConArgs ft_fmap con
1559
1560 eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat]
1561 (error_Expr "Void fmap")]
1562 | otherwise = map fmap_eqn data_cons
1563
1564 ft_fmap :: FFoldType (State [RdrName] (LHsExpr RdrName))
1565 ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x -- fmap f = \x -> x
1566 , ft_var = return f_Expr -- fmap f = f
1567 , ft_fun = \g h -> do -- fmap f = \x b -> h (x (g b))
1568 gg <- g
1569 hh <- h
1570 mkSimpleLam2 $ \x b -> return $ nlHsApp hh (nlHsApp x (nlHsApp gg b))
1571 , ft_tup = \t gs -> do -- fmap f = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
1572 gg <- sequence gs
1573 mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
1574 , ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g -- fmap f = fmap g
1575 , ft_forall = \_ g -> g
1576 , ft_bad_app = panic "in other argument"
1577 , ft_co_var = panic "contravariant" }
1578
1579 -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
1580 match_for_con :: [LPat RdrName] -> DataCon -> [LHsExpr RdrName]
1581 -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
1582 match_for_con = mkSimpleConMatch $
1583 \con_name xs -> return $ nlHsApps con_name xs -- Con x1 x2 ..
1584
1585 {-
1586 Utility functions related to Functor deriving.
1587
1588 Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
1589 This function works like a fold: it makes a value of type 'a' in a bottom up way.
1590 -}
1591
1592 -- Generic traversal for Functor deriving
1593 data FFoldType a -- Describes how to fold over a Type in a functor like way
1594 = FT { ft_triv :: a -- Does not contain variable
1595 , ft_var :: a -- The variable itself
1596 , ft_co_var :: a -- The variable itself, contravariantly
1597 , ft_fun :: a -> a -> a -- Function type
1598 , ft_tup :: TyCon -> [a] -> a -- Tuple type
1599 , ft_ty_app :: Type -> a -> a -- Type app, variable only in last argument
1600 , ft_bad_app :: a -- Type app, variable other than in last argument
1601 , ft_forall :: TcTyVar -> a -> a -- Forall type
1602 }
1603
1604 functorLikeTraverse :: forall a.
1605 TyVar -- ^ Variable to look for
1606 -> FFoldType a -- ^ How to fold
1607 -> Type -- ^ Type to process
1608 -> a
1609 functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar
1610 , ft_co_var = caseCoVar, ft_fun = caseFun
1611 , ft_tup = caseTuple, ft_ty_app = caseTyApp
1612 , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
1613 ty
1614 = fst (go False ty)
1615 where
1616 go :: Bool -- Covariant or contravariant context
1617 -> Type
1618 -> (a, Bool) -- (result of type a, does type contain var)
1619
1620 go co ty | Just ty' <- coreView ty = go co ty'
1621 go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True)
1622 go co (ForAllTy (Anon x) y) | isPredTy x = go co y
1623 | xc || yc = (caseFun xr yr,True)
1624 where (xr,xc) = go (not co) x
1625 (yr,yc) = go co y
1626 go co (AppTy x y) | xc = (caseWrongArg, True)
1627 | yc = (caseTyApp x yr, True)
1628 where (_, xc) = go co x
1629 (yr,yc) = go co y
1630 go co ty@(TyConApp con args)
1631 | not (or xcs) = (caseTrivial, False) -- Variable does not occur
1632 -- At this point we know that xrs, xcs is not empty,
1633 -- and at least one xr is True
1634 | isTupleTyCon con = (caseTuple con xrs, True)
1635 | or (init xcs) = (caseWrongArg, True) -- T (..var..) ty
1636 | Just (fun_ty, _) <- splitAppTy_maybe ty -- T (..no var..) ty
1637 = (caseTyApp fun_ty (last xrs), True)
1638 | otherwise = (caseWrongArg, True) -- Non-decomposable (eg type function)
1639 where
1640 (xrs,xcs) = unzip (map (go co) args)
1641 go _ (ForAllTy (Named _ Visible) _) = panic "unexpected visible binder"
1642 go co (ForAllTy (Named v _) x) | v /= var && xc = (caseForAll v xr,True)
1643 where (xr,xc) = go co x
1644
1645 go _ _ = (caseTrivial,False)
1646
1647 -- Return all syntactic subterms of ty that contain var somewhere
1648 -- These are the things that should appear in instance constraints
1649 deepSubtypesContaining :: TyVar -> Type -> [TcType]
1650 deepSubtypesContaining tv
1651 = functorLikeTraverse tv
1652 (FT { ft_triv = []
1653 , ft_var = []
1654 , ft_fun = (++)
1655 , ft_tup = \_ xs -> concat xs
1656 , ft_ty_app = (:)
1657 , ft_bad_app = panic "in other argument"
1658 , ft_co_var = panic "contravariant"
1659 , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs })
1660
1661
1662 foldDataConArgs :: FFoldType a -> DataCon -> [a]
1663 -- Fold over the arguments of the datacon
1664 foldDataConArgs ft con
1665 = map foldArg (dataConOrigArgTys con)
1666 where
1667 foldArg
1668 = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of
1669 Just tv -> functorLikeTraverse tv ft
1670 Nothing -> const (ft_triv ft)
1671 -- If we are deriving Foldable for a GADT, there is a chance that the last
1672 -- type variable in the data type isn't actually a type variable at all.
1673 -- (for example, this can happen if the last type variable is refined to
1674 -- be a concrete type such as Int). If the last type variable is refined
1675 -- to be a specific type, then getTyVar_maybe will return Nothing.
1676 -- See Note [DeriveFoldable with ExistentialQuantification]
1677 --
1678 -- The kind checks have ensured the last type parameter is of kind *.
1679
1680 -- Make a HsLam using a fresh variable from a State monad
1681 mkSimpleLam :: (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1682 -> State [RdrName] (LHsExpr RdrName)
1683 -- (mkSimpleLam fn) returns (\x. fn(x))
1684 mkSimpleLam lam = do
1685 (n:names) <- get
1686 put names
1687 body <- lam (nlHsVar n)
1688 return (mkHsLam [nlVarPat n] body)
1689
1690 mkSimpleLam2 :: (LHsExpr RdrName -> LHsExpr RdrName
1691 -> State [RdrName] (LHsExpr RdrName))
1692 -> State [RdrName] (LHsExpr RdrName)
1693 mkSimpleLam2 lam = do
1694 (n1:n2:names) <- get
1695 put names
1696 body <- lam (nlHsVar n1) (nlHsVar n2)
1697 return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
1698
1699 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
1700 mkSimpleConMatch :: Monad m => (RdrName -> [LHsExpr RdrName] -> m (LHsExpr RdrName))
1701 -> [LPat RdrName]
1702 -> DataCon
1703 -> [LHsExpr RdrName]
1704 -> m (LMatch RdrName (LHsExpr RdrName))
1705 mkSimpleConMatch fold extra_pats con insides = do
1706 let con_name = getRdrName con
1707 let vars_needed = takeList insides as_RDRs
1708 let pat = nlConVarPat con_name vars_needed
1709 rhs <- fold con_name (zipWith nlHsApp insides (map nlHsVar vars_needed))
1710 return $ mkMatch (extra_pats ++ [pat]) rhs (noLoc emptyLocalBinds)
1711
1712 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
1713 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [a]
1714 -> m (LMatch RdrName (LHsExpr RdrName)))
1715 -> TyCon -> [a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
1716 mkSimpleTupleCase match_for_con tc insides x
1717 = do { let data_con = tyConSingleDataCon tc
1718 ; match <- match_for_con [] data_con insides
1719 ; return $ nlHsCase x [match] }
1720
1721 {-
1722 ************************************************************************
1723 * *
1724 Foldable instances
1725
1726 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1727
1728 * *
1729 ************************************************************************
1730
1731 Deriving Foldable instances works the same way as Functor instances,
1732 only Foldable instances are not possible for function types at all.
1733 Here the derived instance for the type T above is:
1734
1735 instance Foldable T where
1736 foldr f z (T1 x1 x2 x3) = $(foldr 'a 'b1) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a 'b2) x3 z ) )
1737
1738 The cases are:
1739
1740 $(foldr 'a 'b) = \x z -> z -- when b does not contain a
1741 $(foldr 'a 'a) = f
1742 $(foldr 'a '(b1,b2)) = \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
1743 $(foldr 'a '(T b1 b2)) = \x z -> foldr $(foldr 'a 'b2) z x -- when a only occurs in the last parameter, b2
1744
1745 Note that the arguments to the real foldr function are the wrong way around,
1746 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
1747
1748 Foldable instances differ from Functor and Traversable instances in that
1749 Foldable instances can be derived for data types in which the last type
1750 variable is existentially quantified. In particular, if the last type variable
1751 is refined to a more specific type in a GADT:
1752
1753 data GADT a where
1754 G :: a ~ Int => a -> G Int
1755
1756 then the deriving machinery does not attempt to check that the type a contains
1757 Int, since it is not syntactically equal to a type variable. That is, the
1758 derived Foldable instance for GADT is:
1759
1760 instance Foldable GADT where
1761 foldr _ z (GADT _) = z
1762
1763 See Note [DeriveFoldable with ExistentialQuantification].
1764
1765 -}
1766
1767 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1768 gen_Foldable_binds loc tycon
1769 = (listToBag [foldr_bind, foldMap_bind], emptyBag)
1770 where
1771 data_cons = tyConDataCons tycon
1772
1773 foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns
1774 eqns = map foldr_eqn data_cons
1775 foldr_eqn con = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs
1776 where
1777 parts = sequence $ foldDataConArgs ft_foldr con
1778
1779 foldMap_bind = mkRdrFunBind (L loc foldMap_RDR) (map foldMap_eqn data_cons)
1780 foldMap_eqn con = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs
1781 where
1782 parts = sequence $ foldDataConArgs ft_foldMap con
1783
1784 ft_foldr :: FFoldType (State [RdrName] (LHsExpr RdrName))
1785 ft_foldr = FT { ft_triv = mkSimpleLam2 $ \_ z -> return z -- foldr f = \x z -> z
1786 , ft_var = return f_Expr -- foldr f = f
1787 , ft_tup = \t g -> do gg <- sequence g -- foldr f = (\x z -> case x of ...)
1788 mkSimpleLam2 $ \x z -> mkSimpleTupleCase (match_foldr z) t gg x
1789 , ft_ty_app = \_ g -> do gg <- g -- foldr f = (\x z -> foldr g z x)
1790 mkSimpleLam2 $ \x z -> return $ nlHsApps foldable_foldr_RDR [gg,z,x]
1791 , ft_forall = \_ g -> g
1792 , ft_co_var = panic "contravariant"
1793 , ft_fun = panic "function"
1794 , ft_bad_app = panic "in other argument" }
1795
1796 match_foldr z = mkSimpleConMatch $ \_con_name xs -> return $ foldr nlHsApp z xs -- g1 v1 (g2 v2 (.. z))
1797
1798 ft_foldMap :: FFoldType (State [RdrName] (LHsExpr RdrName))
1799 ft_foldMap = FT { ft_triv = mkSimpleLam $ \_ -> return mempty_Expr -- foldMap f = \x -> mempty
1800 , ft_var = return f_Expr -- foldMap f = f
1801 , ft_tup = \t g -> do gg <- sequence g -- foldMap f = \x -> case x of (..,)
1802 mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg
1803 , ft_ty_app = \_ g -> nlHsApp foldMap_Expr <$> g -- foldMap f = foldMap g
1804 , ft_forall = \_ g -> g
1805 , ft_co_var = panic "contravariant"
1806 , ft_fun = panic "function"
1807 , ft_bad_app = panic "in other argument" }
1808
1809 match_foldMap = mkSimpleConMatch $ \_con_name xs -> return $
1810 case xs of
1811 [] -> mempty_Expr
1812 xs -> foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs
1813
1814 {-
1815 ************************************************************************
1816 * *
1817 Traversable instances
1818
1819 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1820 * *
1821 ************************************************************************
1822
1823 Again, Traversable is much like Functor and Foldable.
1824
1825 The cases are:
1826
1827 $(traverse 'a 'b) = pure -- when b does not contain a
1828 $(traverse 'a 'a) = f
1829 $(traverse 'a '(b1,b2)) = \x -> case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
1830 $(traverse 'a '(T b1 b2)) = traverse $(traverse 'a 'b2) -- when a only occurs in the last parameter, b2
1831
1832 Note that the generated code is not as efficient as it could be. For instance:
1833
1834 data T a = T Int a deriving Traversable
1835
1836 gives the function: traverse f (T x y) = T <$> pure x <*> f y
1837 instead of: traverse f (T x y) = T x <$> f y
1838 -}
1839
1840 gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1841 gen_Traversable_binds loc tycon
1842 = (unitBag traverse_bind, emptyBag)
1843 where
1844 data_cons = tyConDataCons tycon
1845
1846 traverse_bind = mkRdrFunBind (L loc traverse_RDR) eqns
1847 eqns = map traverse_eqn data_cons
1848 traverse_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
1849 where
1850 parts = sequence $ foldDataConArgs ft_trav con
1851
1852
1853 ft_trav :: FFoldType (State [RdrName] (LHsExpr RdrName))
1854 ft_trav = FT { ft_triv = return pure_Expr -- traverse f = pure x
1855 , ft_var = return f_Expr -- traverse f = f x
1856 , ft_tup = \t gs -> do -- traverse f = \x -> case x of (a1,a2,..) ->
1857 gg <- sequence gs -- (,,) <$> g1 a1 <*> g2 a2 <*> ..
1858 mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
1859 , ft_ty_app = \_ g -> nlHsApp traverse_Expr <$> g -- traverse f = travese g
1860 , ft_forall = \_ g -> g
1861 , ft_co_var = panic "contravariant"
1862 , ft_fun = panic "function"
1863 , ft_bad_app = panic "in other argument" }
1864
1865 -- Con a1 a2 ... -> Con <$> g1 a1 <*> g2 a2 <*> ...
1866 match_for_con = mkSimpleConMatch $
1867 \con_name xs -> return $ mkApCon (nlHsVar con_name) xs
1868
1869 -- ((Con <$> x1) <*> x2) <*> ..
1870 mkApCon con [] = nlHsApps pure_RDR [con]
1871 mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
1872 where appAp x y = nlHsApps ap_RDR [x,y]
1873
1874 {-
1875 ************************************************************************
1876 * *
1877 Lift instances
1878 * *
1879 ************************************************************************
1880
1881 Example:
1882
1883 data Foo a = Foo a | a :^: a deriving Lift
1884
1885 ==>
1886
1887 instance (Lift a) => Lift (Foo a) where
1888 lift (Foo a)
1889 = appE
1890 (conE
1891 (mkNameG_d "package-name" "ModuleName" "Foo"))
1892 (lift a)
1893 lift (u :^: v)
1894 = infixApp
1895 (lift u)
1896 (conE
1897 (mkNameG_d "package-name" "ModuleName" ":^:"))
1898 (lift v)
1899
1900 Note that (mkNameG_d "package-name" "ModuleName" "Foo") is equivalent to what
1901 'Foo would be when using the -XTemplateHaskell extension. To make sure that
1902 -XDeriveLift can be used on stage-1 compilers, however, we expliticly invoke
1903 makeG_d.
1904 -}
1905
1906 gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1907 gen_Lift_binds loc tycon
1908 | null data_cons = (unitBag (L loc $ mkFunBind (L loc lift_RDR)
1909 [mkMatch [nlWildPat] errorMsg_Expr
1910 (noLoc emptyLocalBinds)])
1911 , emptyBag)
1912 | otherwise = (unitBag lift_bind, emptyBag)
1913 where
1914 errorMsg_Expr = nlHsVar error_RDR `nlHsApp` nlHsLit
1915 (mkHsString $ "Can't lift value of empty datatype " ++ tycon_str)
1916
1917 lift_bind = mk_FunBind loc lift_RDR (map pats_etc data_cons)
1918 data_cons = tyConDataCons tycon
1919 tycon_str = occNameString . nameOccName . tyConName $ tycon
1920
1921 pats_etc data_con
1922 = ([con_pat], lift_Expr)
1923 where
1924 con_pat = nlConVarPat data_con_RDR as_needed
1925 data_con_RDR = getRdrName data_con
1926 con_arity = dataConSourceArity data_con
1927 as_needed = take con_arity as_RDRs
1928 lifted_as = zipWithEqual "mk_lift_app" mk_lift_app
1929 tys_needed as_needed
1930 tycon_name = tyConName tycon
1931 is_infix = dataConIsInfix data_con
1932 tys_needed = dataConOrigArgTys data_con
1933
1934 mk_lift_app ty a
1935 | not (isUnliftedType ty) = nlHsApp (nlHsVar lift_RDR)
1936 (nlHsVar a)
1937 | otherwise = nlHsApp (nlHsVar litE_RDR)
1938 (primLitOp (mkBoxExp (nlHsVar a)))
1939 where (primLitOp, mkBoxExp) = primLitOps "Lift" tycon ty
1940
1941 pkg_name = unitIdString . moduleUnitId
1942 . nameModule $ tycon_name
1943 mod_name = moduleNameString . moduleName . nameModule $ tycon_name
1944 con_name = occNameString . nameOccName . dataConName $ data_con
1945
1946 conE_Expr = nlHsApp (nlHsVar conE_RDR)
1947 (nlHsApps mkNameG_dRDR
1948 (map (nlHsLit . mkHsString)
1949 [pkg_name, mod_name, con_name]))
1950
1951 lift_Expr
1952 | is_infix = nlHsApps infixApp_RDR [a1, conE_Expr, a2]
1953 | otherwise = foldl mk_appE_app conE_Expr lifted_as
1954 (a1:a2:_) = lifted_as
1955
1956 mk_appE_app :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1957 mk_appE_app a b = nlHsApps appE_RDR [a, b]
1958
1959 {-
1960 ************************************************************************
1961 * *
1962 Newtype-deriving instances
1963 * *
1964 ************************************************************************
1965
1966 Note [Newtype-deriving instances]
1967 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1968 We take every method in the original instance and `coerce` it to fit
1969 into the derived instance. We need a type annotation on the argument
1970 to `coerce` to make it obvious what instantiation of the method we're
1971 coercing from. So from, say,
1972 class C a b where
1973 op :: a -> [b] -> Int
1974
1975 newtype T x = MkT <rep-ty>
1976
1977 instance C a <rep-ty> => C a (T x) where
1978 op = (coerce
1979 (op :: a -> [<rep-ty>] -> Int)
1980 ) :: a -> [T x] -> Int
1981
1982 Notice that we give the 'coerce' call two type signatures: one to
1983 fix the of the inner call, and one for the expected type. The outer
1984 type signature ought to be redundant, but may improve error messages.
1985 The inner one is essential to fix the type at which 'op' is called.
1986
1987 See #8503 for more discussion.
1988
1989 Here's a wrinkle. Supppose 'op' is locally overloaded:
1990
1991 class C2 b where
1992 op2 :: forall a. Eq a => a -> [b] -> Int
1993
1994 Then we could do exactly as above, but it's a bit redundant to
1995 instantiate op, then re-generalise with the inner signature.
1996 (The inner sig is only there to fix the type at which 'op' is
1997 called.) So we just instantiate the signature, and add
1998
1999 instance C2 <rep-ty> => C2 (T x) where
2000 op2 = (coerce
2001 (op2 :: a -> [<rep-ty>] -> Int)
2002 ) :: forall a. Eq a => a -> [T x] -> Int
2003 -}
2004
2005 gen_Newtype_binds :: SrcSpan
2006 -> Class -- the class being derived
2007 -> [TyVar] -- the tvs in the instance head
2008 -> [Type] -- instance head parameters (incl. newtype)
2009 -> Type -- the representation type (already eta-reduced)
2010 -> LHsBinds RdrName
2011 -- See Note [Newtype-deriving instances]
2012 gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty
2013 = listToBag $ map mk_bind (classMethods cls)
2014 where
2015 coerce_RDR = getRdrName coerceId
2016
2017 mk_bind :: Id -> LHsBind RdrName
2018 mk_bind meth_id
2019 = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch [] rhs_expr]
2020 where
2021 Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty meth_id
2022
2023 -- See "wrinkle" in Note [Newtype-deriving instances]
2024 (_, _, from_ty') = tcSplitSigmaTy from_ty
2025
2026 meth_RDR = getRdrName meth_id
2027
2028 rhs_expr = ( nlHsVar coerce_RDR
2029 `nlHsApp`
2030 (nlHsVar meth_RDR `nlExprWithTySig` toLHsSigWcType from_ty'))
2031 `nlExprWithTySig` toLHsSigWcType to_ty
2032
2033
2034 nlExprWithTySig :: LHsExpr RdrName -> LHsSigWcType RdrName -> LHsExpr RdrName
2035 nlExprWithTySig e s = noLoc (ExprWithTySig e s)
2036
2037 mkCoerceClassMethEqn :: Class -- the class being derived
2038 -> [TyVar] -- the tvs in the instance head
2039 -> [Type] -- instance head parameters (incl. newtype)
2040 -> Type -- the representation type (already eta-reduced)
2041 -> Id -- the method to look at
2042 -> Pair Type
2043 -- See Note [Newtype-deriving instances]
2044 -- The pair is the (from_type, to_type), where to_type is
2045 -- the type of the method we are tyrying to get
2046 mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty id
2047 = Pair (substTy rhs_subst user_meth_ty)
2048 (substTy lhs_subst user_meth_ty)
2049 where
2050 cls_tvs = classTyVars cls
2051 in_scope = mkInScopeSet $ mkVarSet inst_tvs
2052 lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs cls_tys)
2053 rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast cls_tys rhs_ty))
2054 (_class_tvs, _class_constraint, user_meth_ty)
2055 = tcSplitMethodTy (varType id)
2056
2057 changeLast :: [a] -> a -> [a]
2058 changeLast [] _ = panic "changeLast"
2059 changeLast [_] x = [x]
2060 changeLast (x:xs) x' = x : changeLast xs x'
2061
2062 {-
2063 ************************************************************************
2064 * *
2065 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
2066 * *
2067 ************************************************************************
2068
2069 \begin{verbatim}
2070 data Foo ... = ...
2071
2072 con2tag_Foo :: Foo ... -> Int#
2073 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
2074 maxtag_Foo :: Int -- ditto (NB: not unlifted)
2075 \end{verbatim}
2076
2077 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
2078 fiddling around.
2079 -}
2080
2081 genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName)
2082 genAuxBindSpec loc (DerivCon2Tag tycon)
2083 = (mk_FunBind loc rdr_name eqns,
2084 L loc (TypeSig [L loc rdr_name] sig_ty))
2085 where
2086 rdr_name = con2tag_RDR tycon
2087
2088 sig_ty = mkLHsSigWcType $ L loc $ HsCoreTy $
2089 mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
2090 mkParentType tycon `mkFunTy` intPrimTy
2091
2092 lots_of_constructors = tyConFamilySize tycon > 8
2093 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
2094 -- but we don't do vectored returns any more.
2095
2096 eqns | lots_of_constructors = [get_tag_eqn]
2097 | otherwise = map mk_eqn (tyConDataCons tycon)
2098
2099 get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
2100
2101 mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
2102 mk_eqn con = ([nlWildConPat con],
2103 nlHsLit (HsIntPrim ""
2104 (toInteger ((dataConTag con) - fIRST_TAG))))
2105
2106 genAuxBindSpec loc (DerivTag2Con tycon)
2107 = (mk_FunBind loc rdr_name
2108 [([nlConVarPat intDataCon_RDR [a_RDR]],
2109 nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
2110 L loc (TypeSig [L loc rdr_name] sig_ty))
2111 where
2112 sig_ty = mkLHsSigWcType $ L loc $
2113 HsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
2114 intTy `mkFunTy` mkParentType tycon
2115
2116 rdr_name = tag2con_RDR tycon
2117
2118 genAuxBindSpec loc (DerivMaxTag tycon)
2119 = (mkHsVarBind loc rdr_name rhs,
2120 L loc (TypeSig [L loc rdr_name] sig_ty))
2121 where
2122 rdr_name = maxtag_RDR tycon
2123 sig_ty = mkLHsSigWcType (L loc (HsCoreTy intTy))
2124 rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim "" max_tag))
2125 max_tag = case (tyConDataCons tycon) of
2126 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
2127
2128 type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings
2129 ( Bag (LHsBind RdrName, LSig RdrName)
2130 -- Extra bindings (used by Generic only)
2131 , Bag (FamInst) -- Extra family instances
2132 , Bag (InstInfo RdrName)) -- Extra instances
2133
2134 genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
2135 genAuxBinds loc b = genAuxBinds' b2 where
2136 (b1,b2) = partitionBagWith splitDerivAuxBind b
2137 splitDerivAuxBind (DerivAuxBind x) = Left x
2138 splitDerivAuxBind x = Right x
2139
2140 rm_dups = foldrBag dup_check emptyBag
2141 dup_check a b = if anyBag (== a) b then b else consBag a b
2142
2143 genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
2144 genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec loc) (rm_dups b1)
2145 , emptyBag, emptyBag)
2146 f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
2147 f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
2148 f (DerivHsBind b) = add1 b
2149 f (DerivFamInst t) = add2 t
2150 f (DerivInst i) = add3 i
2151
2152 add1 x (a,b,c) = (x `consBag` a,b,c)
2153 add2 x (a,b,c) = (a,x `consBag` b,c)
2154 add3 x (a,b,c) = (a,b,x `consBag` c)
2155
2156 mk_data_type_name :: TyCon -> RdrName -- "$tT"
2157 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
2158
2159 mk_constr_name :: DataCon -> RdrName -- "$cC"
2160 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
2161
2162 mkParentType :: TyCon -> Type
2163 -- Turn the representation tycon of a family into
2164 -- a use of its family constructor
2165 mkParentType tc
2166 = case tyConFamInst_maybe tc of
2167 Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
2168 Just (fam_tc,tys) -> mkTyConApp fam_tc tys
2169
2170 {-
2171 ************************************************************************
2172 * *
2173 \subsection{Utility bits for generating bindings}
2174 * *
2175 ************************************************************************
2176 -}
2177
2178 mk_FunBind :: SrcSpan -> RdrName
2179 -> [([LPat RdrName], LHsExpr RdrName)]
2180 -> LHsBind RdrName
2181 mk_FunBind = mk_HRFunBind 0 -- by using mk_FunBind and not mk_HRFunBind,
2182 -- the caller says that the Void case needs no
2183 -- patterns
2184
2185 -- | This variant of 'mk_FunBind' puts an 'Arity' number of wildcards before
2186 -- the "=" in the empty-data-decl case. This is necessary if the function
2187 -- has a higher-rank type, like foldl. (See deriving/should_compile/T4302)
2188 mk_HRFunBind :: Arity -> SrcSpan -> RdrName
2189 -> [([LPat RdrName], LHsExpr RdrName)]
2190 -> LHsBind RdrName
2191 mk_HRFunBind arity loc fun pats_and_exprs
2192 = mkHRRdrFunBind arity (L loc fun) matches
2193 where
2194 matches = [mkMatch p e (noLoc emptyLocalBinds) | (p,e) <-pats_and_exprs]
2195
2196 mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
2197 mkRdrFunBind = mkHRRdrFunBind 0
2198
2199 mkHRRdrFunBind :: Arity -> Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
2200 mkHRRdrFunBind arity fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
2201 where
2202 -- Catch-all eqn looks like
2203 -- fmap = error "Void fmap"
2204 -- It's needed if there no data cons at all,
2205 -- which can happen with -XEmptyDataDecls
2206 -- See Trac #4302
2207 matches' = if null matches
2208 then [mkMatch (replicate arity nlWildPat)
2209 (error_Expr str) (noLoc emptyLocalBinds)]
2210 else matches
2211 str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
2212
2213 box :: String -- The class involved
2214 -> TyCon -- The tycon involved
2215 -> LHsExpr RdrName -- The argument
2216 -> Type -- The argument type
2217 -> LHsExpr RdrName -- Boxed version of the arg
2218 -- See Note [Deriving and unboxed types] in TcDeriv
2219 box cls_str tycon arg arg_ty = nlHsApp (nlHsVar box_con) arg
2220 where
2221 box_con = assoc_ty_id cls_str tycon boxConTbl arg_ty
2222
2223 ---------------------
2224 primOrdOps :: String -- The class involved
2225 -> TyCon -- The tycon involved
2226 -> Type -- The type
2227 -> (RdrName, RdrName, RdrName, RdrName, RdrName) -- (lt,le,eq,ge,gt)
2228 -- See Note [Deriving and unboxed types] in TcDeriv
2229 primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty
2230
2231 primLitOps :: String -- The class involved
2232 -> TyCon -- The tycon involved
2233 -> Type -- The type
2234 -> ( LHsExpr RdrName -> LHsExpr RdrName -- Constructs a Q Exp value
2235 , LHsExpr RdrName -> LHsExpr RdrName -- Constructs a boxed value
2236 )
2237 primLitOps str tycon ty = ( assoc_ty_id str tycon litConTbl ty
2238 , \v -> nlHsVar boxRDR `nlHsApp` v
2239 )
2240 where
2241 boxRDR
2242 | ty `eqType` addrPrimTy = unpackCString_RDR
2243 | otherwise = assoc_ty_id str tycon boxConTbl ty
2244
2245 ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
2246 ordOpTbl
2247 = [(charPrimTy , (ltChar_RDR , leChar_RDR , eqChar_RDR , geChar_RDR , gtChar_RDR ))
2248 ,(intPrimTy , (ltInt_RDR , leInt_RDR , eqInt_RDR , geInt_RDR , gtInt_RDR ))
2249 ,(wordPrimTy , (ltWord_RDR , leWord_RDR , eqWord_RDR , geWord_RDR , gtWord_RDR ))
2250 ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR , eqAddr_RDR , geAddr_RDR , gtAddr_RDR ))
2251 ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR , eqFloat_RDR , geFloat_RDR , gtFloat_RDR ))
2252 ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR, eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ]
2253
2254 boxConTbl :: [(Type, RdrName)]
2255 boxConTbl
2256 = [(charPrimTy , getRdrName charDataCon )
2257 ,(intPrimTy , getRdrName intDataCon )
2258 ,(wordPrimTy , getRdrName wordDataCon )
2259 ,(floatPrimTy , getRdrName floatDataCon )
2260 ,(doublePrimTy, getRdrName doubleDataCon)
2261 ]
2262
2263 -- | A table of postfix modifiers for unboxed values.
2264 postfixModTbl :: [(Type, String)]
2265 postfixModTbl
2266 = [(charPrimTy , "#" )
2267 ,(intPrimTy , "#" )
2268 ,(wordPrimTy , "##")
2269 ,(floatPrimTy , "#" )
2270 ,(doublePrimTy, "##")
2271 ]
2272
2273 litConTbl :: [(Type, LHsExpr RdrName -> LHsExpr RdrName)]
2274 litConTbl
2275 = [(charPrimTy , nlHsApp (nlHsVar charPrimL_RDR))
2276 ,(intPrimTy , nlHsApp (nlHsVar intPrimL_RDR)
2277 . nlHsApp (nlHsVar toInteger_RDR))
2278 ,(wordPrimTy , nlHsApp (nlHsVar wordPrimL_RDR)
2279 . nlHsApp (nlHsVar toInteger_RDR))
2280 ,(addrPrimTy , nlHsApp (nlHsVar stringPrimL_RDR)
2281 . nlHsApp (nlHsApp
2282 (nlHsVar map_RDR)
2283 (compose_RDR `nlHsApps`
2284 [ nlHsVar fromIntegral_RDR
2285 , nlHsVar fromEnum_RDR
2286 ])))
2287 ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR)
2288 . nlHsApp (nlHsVar toRational_RDR))
2289 ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR)
2290 . nlHsApp (nlHsVar toRational_RDR))
2291 ]
2292
2293 -- | Lookup `Type` in an association list.
2294 assoc_ty_id :: String -- The class involved
2295 -> TyCon -- The tycon involved
2296 -> [(Type,a)] -- The table
2297 -> Type -- The type
2298 -> a -- The result of the lookup
2299 assoc_ty_id cls_str _ tbl ty
2300 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
2301 text "for primitive type" <+> ppr ty)
2302 | otherwise = head res
2303 where
2304 res = [id | (ty',id) <- tbl, ty `eqType` ty']
2305
2306 -----------------------------------------------------------------------
2307
2308 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2309 and_Expr a b = genOpApp a and_RDR b
2310
2311 -----------------------------------------------------------------------
2312
2313 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2314 eq_Expr tycon ty a b
2315 | not (isUnliftedType ty) = genOpApp a eq_RDR b
2316 | otherwise = genPrimOpApp a prim_eq b
2317 where
2318 (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
2319
2320 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
2321 untag_Expr _ [] expr = expr
2322 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
2323 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
2324 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
2325
2326 enum_from_to_Expr
2327 :: LHsExpr RdrName -> LHsExpr RdrName
2328 -> LHsExpr RdrName
2329 enum_from_then_to_Expr
2330 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2331 -> LHsExpr RdrName
2332
2333 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
2334 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
2335
2336 showParen_Expr
2337 :: LHsExpr RdrName -> LHsExpr RdrName
2338 -> LHsExpr RdrName
2339
2340 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
2341
2342 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
2343
2344 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
2345 nested_compose_Expr [e] = parenify e
2346 nested_compose_Expr (e:es)
2347 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
2348
2349 -- impossible_Expr is used in case RHSs that should never happen.
2350 -- We generate these to keep the desugarer from complaining that they *might* happen!
2351 error_Expr :: String -> LHsExpr RdrName
2352 error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
2353
2354 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
2355 -- method. It is currently only used by Enum.{succ,pred}
2356 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
2357 illegal_Expr meth tp msg =
2358 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
2359
2360 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
2361 -- to include the value of a_RDR in the error string.
2362 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
2363 illegal_toEnum_tag tp maxtag =
2364 nlHsApp (nlHsVar error_RDR)
2365 (nlHsApp (nlHsApp (nlHsVar append_RDR)
2366 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
2367 (nlHsApp (nlHsApp (nlHsApp
2368 (nlHsVar showsPrec_RDR)
2369 (nlHsIntLit 0))
2370 (nlHsVar a_RDR))
2371 (nlHsApp (nlHsApp
2372 (nlHsVar append_RDR)
2373 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
2374 (nlHsApp (nlHsApp (nlHsApp
2375 (nlHsVar showsPrec_RDR)
2376 (nlHsIntLit 0))
2377 (nlHsVar maxtag))
2378 (nlHsLit (mkHsString ")"))))))
2379
2380 parenify :: LHsExpr RdrName -> LHsExpr RdrName
2381 parenify e@(L _ (HsVar _)) = e
2382 parenify e = mkHsPar e
2383
2384 -- genOpApp wraps brackets round the operator application, so that the
2385 -- renamer won't subsequently try to re-associate it.
2386 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2387 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
2388
2389 genPrimOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2390 genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2))
2391
2392 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
2393 :: RdrName
2394 a_RDR = mkVarUnqual (fsLit "a")
2395 b_RDR = mkVarUnqual (fsLit "b")
2396 c_RDR = mkVarUnqual (fsLit "c")
2397 d_RDR = mkVarUnqual (fsLit "d")
2398 f_RDR = mkVarUnqual (fsLit "f")
2399 k_RDR = mkVarUnqual (fsLit "k")
2400 z_RDR = mkVarUnqual (fsLit "z")
2401 ah_RDR = mkVarUnqual (fsLit "a#")
2402 bh_RDR = mkVarUnqual (fsLit "b#")
2403 ch_RDR = mkVarUnqual (fsLit "c#")
2404 dh_RDR = mkVarUnqual (fsLit "d#")
2405
2406 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
2407 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
2408 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
2409 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
2410
2411 a_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
2412 false_Expr, true_Expr, fmap_Expr, pure_Expr, mempty_Expr, foldMap_Expr, traverse_Expr :: LHsExpr RdrName
2413 a_Expr = nlHsVar a_RDR
2414 -- b_Expr = nlHsVar b_RDR
2415 c_Expr = nlHsVar c_RDR
2416 f_Expr = nlHsVar f_RDR
2417 z_Expr = nlHsVar z_RDR
2418 ltTag_Expr = nlHsVar ltTag_RDR
2419 eqTag_Expr = nlHsVar eqTag_RDR
2420 gtTag_Expr = nlHsVar gtTag_RDR
2421 false_Expr = nlHsVar false_RDR
2422 true_Expr = nlHsVar true_RDR
2423 fmap_Expr = nlHsVar fmap_RDR
2424 pure_Expr = nlHsVar pure_RDR
2425 mempty_Expr = nlHsVar mempty_RDR
2426 foldMap_Expr = nlHsVar foldMap_RDR
2427 traverse_Expr = nlHsVar traverse_RDR
2428
2429 a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName
2430 a_Pat = nlVarPat a_RDR
2431 b_Pat = nlVarPat b_RDR
2432 c_Pat = nlVarPat c_RDR
2433 d_Pat = nlVarPat d_RDR
2434 f_Pat = nlVarPat f_RDR
2435 k_Pat = nlVarPat k_RDR
2436 z_Pat = nlVarPat z_RDR
2437
2438 minusInt_RDR, tagToEnum_RDR :: RdrName
2439 minusInt_RDR = getRdrName (primOpId IntSubOp )
2440 tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)
2441
2442 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
2443 -- Generates Orig s RdrName, for the binding positions
2444 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
2445 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
2446 maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc
2447
2448 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
2449 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
2450
2451 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
2452 -- ^ Make a top-level binder name for an auxiliary binding for a parent name
2453 -- See Note [Auxiliary binders]
2454 mkAuxBinderName parent occ_fun
2455 = mkRdrUnqual (occ_fun stable_parent_occ)
2456 where
2457 stable_parent_occ = mkOccName (occNameSpace parent_occ) stable_string
2458 stable_string
2459 | opt_PprStyle_Debug = parent_stable
2460 | otherwise = parent_stable_hash
2461 parent_stable = nameStableString parent
2462 parent_stable_hash =
2463 let Fingerprint high low = fingerprintString parent_stable
2464 in toBase62 high ++ toBase62Padded low
2465 -- See Note [Base 62 encoding 128-bit integers]
2466 parent_occ = nameOccName parent
2467
2468
2469 {-
2470 Note [Auxiliary binders]
2471 ~~~~~~~~~~~~~~~~~~~~~~~~
2472 We often want to make a top-level auxiliary binding. E.g. for comparison we haev
2473
2474 instance Ord T where
2475 compare a b = $con2tag a `compare` $con2tag b
2476
2477 $con2tag :: T -> Int
2478 $con2tag = ...code....
2479
2480 Of course these top-level bindings should all have distinct name, and we are
2481 generating RdrNames here. We can't just use the TyCon or DataCon to distinguish
2482 because with standalone deriving two imported TyCons might both be called T!
2483 (See Trac #7947.)
2484
2485 So we use package name, module name and the name of the parent
2486 (T in this example) as part of the OccName we generate for the new binding.
2487 To make the symbol names short we take a base62 hash of the full name.
2488
2489 In the past we used the *unique* from the parent, but that's not stable across
2490 recompilations as uniques are nondeterministic.
2491
2492 Note [DeriveFoldable with ExistentialQuantification]
2493 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2494 Functor and Traversable instances can only be derived for data types whose
2495 last type parameter is truly universally polymorphic. For example:
2496
2497 data T a b where
2498 T1 :: b -> T a b -- YES, b is unconstrained
2499 T2 :: Ord b => b -> T a b -- NO, b is constrained by (Ord b)
2500 T3 :: b ~ Int => b -> T a b -- NO, b is constrained by (b ~ Int)
2501 T4 :: Int -> T a Int -- NO, this is just like T3
2502 T5 :: Ord a => a -> b -> T a b -- YES, b is unconstrained, even
2503 -- though a is existential
2504 T6 :: Int -> T Int b -- YES, b is unconstrained
2505
2506 For Foldable instances, however, we can completely lift the constraint that
2507 the last type parameter be truly universally polymorphic. This means that T
2508 (as defined above) can have a derived Foldable instance:
2509
2510 instance Foldable (T a) where
2511 foldr f z (T1 b) = f b z
2512 foldr f z (T2 b) = f b z
2513 foldr f z (T3 b) = f b z
2514 foldr f z (T4 b) = z
2515 foldr f z (T5 a b) = f b z
2516 foldr f z (T6 a) = z
2517
2518 foldMap f (T1 b) = f b
2519 foldMap f (T2 b) = f b
2520 foldMap f (T3 b) = f b
2521 foldMap f (T4 b) = mempty
2522 foldMap f (T5 a b) = f b
2523 foldMap f (T6 a) = mempty
2524
2525 In a Foldable instance, it is safe to fold over an occurrence of the last type
2526 parameter that is not truly universally polymorphic. However, there is a bit
2527 of subtlety in determining what is actually an occurrence of a type parameter.
2528 T3 and T4, as defined above, provide one example:
2529
2530 data T a b where
2531 ...
2532 T3 :: b ~ Int => b -> T a b
2533 T4 :: Int -> T a Int
2534 ...
2535
2536 instance Foldable (T a) where
2537 ...
2538 foldr f z (T3 b) = f b z
2539 foldr f z (T4 b) = z
2540 ...
2541 foldMap f (T3 b) = f b
2542 foldMap f (T4 b) = mempty
2543 ...
2544
2545 Notice that the argument of T3 is folded over, whereas the argument of T4 is
2546 not. This is because we only fold over constructor arguments that
2547 syntactically mention the universally quantified type parameter of that
2548 particular data constructor. See foldDataConArgs for how this is implemented.
2549
2550 As another example, consider the following data type. The argument of each
2551 constructor has the same type as the last type parameter:
2552
2553 data E a where
2554 E1 :: (a ~ Int) => a -> E a
2555 E2 :: Int -> E Int
2556 E3 :: (a ~ Int) => a -> E Int
2557 E4 :: (a ~ Int) => Int -> E a
2558
2559 Only E1's argument is an occurrence of a universally quantified type variable
2560 that is syntactically equivalent to the last type parameter, so only E1's
2561 argument will be be folded over in a derived Foldable instance.
2562
2563 See Trac #10447 for the original discussion on this feature. Also see
2564 https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor
2565 for a more in-depth explanation.
2566
2567 -}