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