Typos in comments, notes and manual
[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 gen_Eq_binds,
22 gen_Ord_binds,
23 gen_Enum_binds,
24 gen_Bounded_binds,
25 gen_Ix_binds,
26 gen_Show_binds,
27 gen_Read_binds,
28 gen_Data_binds,
29 gen_Lift_binds,
30 gen_Newtype_binds,
31 mkCoerceClassMethEqn,
32 genAuxBinds,
33 ordOpTbl, boxConTbl, litConTbl,
34 mkRdrFunBind, error_Expr
35 ) where
36
37 #include "HsVersions.h"
38
39 import TcRnMonad
40 import HsSyn
41 import RdrName
42 import BasicTypes
43 import DataCon
44 import Name
45 import Fingerprint
46 import Encoding
47
48 import DynFlags
49 import PrelInfo
50 import FamInst
51 import FamInstEnv
52 import PrelNames
53 import THNames
54 import Module ( moduleName, moduleNameString
55 , moduleUnitId, unitIdString )
56 import MkId ( coerceId )
57 import PrimOp
58 import SrcLoc
59 import TyCon
60 import TcEnv
61 import TcType
62 import TcValidity ( checkValidTyFamEqn )
63 import TysPrim
64 import TysWiredIn
65 import Type
66 import Class
67 import VarSet
68 import VarEnv
69 import Util
70 import Var
71 import Outputable
72 import Lexeme
73 import FastString
74 import Pair
75 import Bag
76 import StaticFlags( opt_PprStyle_Debug )
77
78 import Data.List ( partition, intersperse )
79
80 type BagDerivStuff = Bag DerivStuff
81
82 data AuxBindSpec
83 = DerivCon2Tag TyCon -- The con2Tag for given TyCon
84 | DerivTag2Con TyCon -- ...ditto tag2Con
85 | DerivMaxTag TyCon -- ...and maxTag
86 deriving( Eq )
87 -- All these generate ZERO-BASED tag operations
88 -- I.e first constructor has tag 0
89
90 data DerivStuff -- Please add this auxiliary stuff
91 = DerivAuxBind AuxBindSpec
92
93 -- Generics and DeriveAnyClass
94 | DerivFamInst FamInst -- New type family instances
95
96 -- New top-level auxiliary bindings
97 | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB
98
99
100 {-
101 ************************************************************************
102 * *
103 Eq instances
104 * *
105 ************************************************************************
106
107 Here are the heuristics for the code we generate for @Eq@. Let's
108 assume we have a data type with some (possibly zero) nullary data
109 constructors and some ordinary, non-nullary ones (the rest, also
110 possibly zero of them). Here's an example, with both \tr{N}ullary and
111 \tr{O}rdinary data cons.
112
113 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
114
115 * For the ordinary constructors (if any), we emit clauses to do The
116 Usual Thing, e.g.,:
117
118 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
119 (==) (O2 a1) (O2 a2) = a1 == a2
120 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
121
122 Note: if we're comparing unlifted things, e.g., if 'a1' and
123 'a2' are Float#s, then we have to generate
124 case (a1 `eqFloat#` a2) of r -> r
125 for that particular test.
126
127 * If there are a lot of (more than en) nullary constructors, we emit a
128 catch-all clause of the form:
129
130 (==) a b = case (con2tag_Foo a) of { a# ->
131 case (con2tag_Foo b) of { b# ->
132 case (a# ==# b#) of {
133 r -> r }}}
134
135 If con2tag gets inlined this leads to join point stuff, so
136 it's better to use regular pattern matching if there aren't too
137 many nullary constructors. "Ten" is arbitrary, of course
138
139 * If there aren't any nullary constructors, we emit a simpler
140 catch-all:
141
142 (==) a b = False
143
144 * For the @(/=)@ method, we normally just use the default method.
145 If the type is an enumeration type, we could/may/should? generate
146 special code that calls @con2tag_Foo@, much like for @(==)@ shown
147 above.
148
149 We thought about doing this: If we're also deriving 'Ord' for this
150 tycon, we generate:
151 instance ... Eq (Foo ...) where
152 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
153 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
154 However, that requires that (Ord <whatever>) was put in the context
155 for the instance decl, which it probably wasn't, so the decls
156 produced don't get through the typechecker.
157 -}
158
159 gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
160 gen_Eq_binds loc tycon
161 = (method_binds, aux_binds)
162 where
163 all_cons = tyConDataCons tycon
164 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons
165
166 -- If there are ten or more (arbitrary number) nullary constructors,
167 -- use the con2tag stuff. For small types it's better to use
168 -- ordinary pattern matching.
169 (tag_match_cons, pat_match_cons)
170 | nullary_cons `lengthExceeds` 10 = (nullary_cons, non_nullary_cons)
171 | otherwise = ([], all_cons)
172
173 no_tag_match_cons = null tag_match_cons
174
175 fall_through_eqn
176 | no_tag_match_cons -- All constructors have arguments
177 = case pat_match_cons of
178 [] -> [] -- No constructors; no fall-though case
179 [_] -> [] -- One constructor; no fall-though case
180 _ -> -- Two or more constructors; add fall-through of
181 -- (==) _ _ = False
182 [([nlWildPat, nlWildPat], false_Expr)]
183
184 | otherwise -- One or more tag_match cons; add fall-through of
185 -- extract tags compare for equality
186 = [([a_Pat, b_Pat],
187 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
188 (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
189
190 aux_binds | no_tag_match_cons = emptyBag
191 | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
192
193 method_binds = listToBag [eq_bind, ne_bind]
194 eq_bind = mk_FunBind loc eq_RDR (map pats_etc pat_match_cons ++ fall_through_eqn)
195 ne_bind = mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
196 nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
197
198 ------------------------------------------------------------------
199 pats_etc data_con
200 = let
201 con1_pat = nlConVarPat data_con_RDR as_needed
202 con2_pat = nlConVarPat data_con_RDR bs_needed
203
204 data_con_RDR = getRdrName data_con
205 con_arity = length tys_needed
206 as_needed = take con_arity as_RDRs
207 bs_needed = take con_arity bs_RDRs
208 tys_needed = dataConOrigArgTys data_con
209 in
210 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
211 where
212 nested_eq_expr [] [] [] = true_Expr
213 nested_eq_expr tys as bs
214 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
215 where
216 nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
217
218 {-
219 ************************************************************************
220 * *
221 Ord instances
222 * *
223 ************************************************************************
224
225 Note [Generating Ord instances]
226 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
227 Suppose constructors are K1..Kn, and some are nullary.
228 The general form we generate is:
229
230 * Do case on first argument
231 case a of
232 K1 ... -> rhs_1
233 K2 ... -> rhs_2
234 ...
235 Kn ... -> rhs_n
236 _ -> nullary_rhs
237
238 * To make rhs_i
239 If i = 1, 2, n-1, n, generate a single case.
240 rhs_2 case b of
241 K1 {} -> LT
242 K2 ... -> ...eq_rhs(K2)...
243 _ -> GT
244
245 Otherwise do a tag compare against the bigger range
246 (because this is the one most likely to succeed)
247 rhs_3 case tag b of tb ->
248 if 3 <# tg then GT
249 else case b of
250 K3 ... -> ...eq_rhs(K3)....
251 _ -> LT
252
253 * To make eq_rhs(K), which knows that
254 a = K a1 .. av
255 b = K b1 .. bv
256 we just want to compare (a1,b1) then (a2,b2) etc.
257 Take care on the last field to tail-call into comparing av,bv
258
259 * To make nullary_rhs generate this
260 case con2tag a of a# ->
261 case con2tag b of ->
262 a# `compare` b#
263
264 Several special cases:
265
266 * Two or fewer nullary constructors: don't generate nullary_rhs
267
268 * Be careful about unlifted comparisons. When comparing unboxed
269 values we can't call the overloaded functions.
270 See function unliftedOrdOp
271
272 Note [Game plan for deriving Ord]
273 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
274 It's a bad idea to define only 'compare', and build the other binary
275 comparisons on top of it; see Trac #2130, #4019. Reason: we don't
276 want to laboriously make a three-way comparison, only to extract a
277 binary result, something like this:
278 (>) (I# x) (I# y) = case <# x y of
279 True -> False
280 False -> case ==# x y of
281 True -> False
282 False -> True
283
284 This being said, we can get away with generating full code only for
285 'compare' and '<' thus saving us generation of other three operators.
286 Other operators can be cheaply expressed through '<':
287 a <= b = not $ b < a
288 a > b = b < a
289 a >= b = not $ a < b
290
291 So for sufficiently small types (few constructors, or all nullary)
292 we generate all methods; for large ones we just use 'compare'.
293
294 -}
295
296 data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT
297
298 ------------
299 ordMethRdr :: OrdOp -> RdrName
300 ordMethRdr op
301 = case op of
302 OrdCompare -> compare_RDR
303 OrdLT -> lt_RDR
304 OrdLE -> le_RDR
305 OrdGE -> ge_RDR
306 OrdGT -> gt_RDR
307
308 ------------
309 ltResult :: OrdOp -> LHsExpr RdrName
310 -- Knowing a<b, what is the result for a `op` b?
311 ltResult OrdCompare = ltTag_Expr
312 ltResult OrdLT = true_Expr
313 ltResult OrdLE = true_Expr
314 ltResult OrdGE = false_Expr
315 ltResult OrdGT = false_Expr
316
317 ------------
318 eqResult :: OrdOp -> LHsExpr RdrName
319 -- Knowing a=b, what is the result for a `op` b?
320 eqResult OrdCompare = eqTag_Expr
321 eqResult OrdLT = false_Expr
322 eqResult OrdLE = true_Expr
323 eqResult OrdGE = true_Expr
324 eqResult OrdGT = false_Expr
325
326 ------------
327 gtResult :: OrdOp -> LHsExpr RdrName
328 -- Knowing a>b, what is the result for a `op` b?
329 gtResult OrdCompare = gtTag_Expr
330 gtResult OrdLT = false_Expr
331 gtResult OrdLE = false_Expr
332 gtResult OrdGE = true_Expr
333 gtResult OrdGT = true_Expr
334
335 ------------
336 gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
337 gen_Ord_binds loc tycon
338 | null tycon_data_cons -- No data-cons => invoke bale-out case
339 = (unitBag $ mk_FunBind loc compare_RDR [], emptyBag)
340 | otherwise
341 = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
342 where
343 aux_binds | single_con_type = emptyBag
344 | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
345
346 -- Note [Game plan for deriving Ord]
347 other_ops | (last_tag - first_tag) <= 2 -- 1-3 constructors
348 || null non_nullary_cons -- Or it's an enumeration
349 = listToBag [mkOrdOp OrdLT, lE, gT, gE]
350 | otherwise
351 = emptyBag
352
353 negate_expr = nlHsApp (nlHsVar not_RDR)
354 lE = mk_easy_FunBind loc le_RDR [a_Pat, b_Pat] $
355 negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr)
356 gT = mk_easy_FunBind loc gt_RDR [a_Pat, b_Pat] $
357 nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr
358 gE = mk_easy_FunBind loc ge_RDR [a_Pat, b_Pat] $
359 negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) a_Expr) b_Expr)
360
361 get_tag con = dataConTag con - fIRST_TAG
362 -- We want *zero-based* tags, because that's what
363 -- con2Tag returns (generated by untag_Expr)!
364
365 tycon_data_cons = tyConDataCons tycon
366 single_con_type = isSingleton tycon_data_cons
367 (first_con : _) = tycon_data_cons
368 (last_con : _) = reverse tycon_data_cons
369 first_tag = get_tag first_con
370 last_tag = get_tag last_con
371
372 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
373
374
375 mkOrdOp :: OrdOp -> LHsBind RdrName
376 -- Returns a binding op a b = ... compares a and b according to op ....
377 mkOrdOp op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] (mkOrdOpRhs op)
378
379 mkOrdOpRhs :: OrdOp -> LHsExpr RdrName
380 mkOrdOpRhs op -- RHS for comparing 'a' and 'b' according to op
381 | length nullary_cons <= 2 -- Two nullary or fewer, so use cases
382 = nlHsCase (nlHsVar a_RDR) $
383 map (mkOrdOpAlt op) tycon_data_cons
384 -- i.e. case a of { C1 x y -> case b of C1 x y -> ....compare x,y...
385 -- C2 x -> case b of C2 x -> ....comopare x.... }
386
387 | null non_nullary_cons -- All nullary, so go straight to comparing tags
388 = mkTagCmp op
389
390 | otherwise -- Mixed nullary and non-nullary
391 = nlHsCase (nlHsVar a_RDR) $
392 (map (mkOrdOpAlt op) non_nullary_cons
393 ++ [mkHsCaseAlt nlWildPat (mkTagCmp op)])
394
395
396 mkOrdOpAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
397 -- Make the alternative (Ki a1 a2 .. av ->
398 mkOrdOpAlt op data_con
399 = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed)
400 (mkInnerRhs op data_con)
401 where
402 as_needed = take (dataConSourceArity data_con) as_RDRs
403 data_con_RDR = getRdrName data_con
404
405 mkInnerRhs op data_con
406 | single_con_type
407 = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ]
408
409 | tag == first_tag
410 = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
411 , mkHsCaseAlt nlWildPat (ltResult op) ]
412 | tag == last_tag
413 = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
414 , mkHsCaseAlt nlWildPat (gtResult op) ]
415
416 | tag == first_tag + 1
417 = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat first_con)
418 (gtResult op)
419 , mkInnerEqAlt op data_con
420 , mkHsCaseAlt nlWildPat (ltResult op) ]
421 | tag == last_tag - 1
422 = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat last_con)
423 (ltResult op)
424 , mkInnerEqAlt op data_con
425 , mkHsCaseAlt nlWildPat (gtResult op) ]
426
427 | tag > last_tag `div` 2 -- lower range is larger
428 = untag_Expr tycon [(b_RDR, bh_RDR)] $
429 nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
430 (gtResult op) $ -- Definitely GT
431 nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
432 , mkHsCaseAlt nlWildPat (ltResult op) ]
433
434 | otherwise -- upper range is larger
435 = untag_Expr tycon [(b_RDR, bh_RDR)] $
436 nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
437 (ltResult op) $ -- Definitely LT
438 nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
439 , mkHsCaseAlt nlWildPat (gtResult op) ]
440 where
441 tag = get_tag data_con
442 tag_lit = noLoc (HsLit (HsIntPrim "" (toInteger tag)))
443
444 mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
445 -- First argument 'a' known to be built with K
446 -- Returns a case alternative Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...)
447 mkInnerEqAlt op data_con
448 = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $
449 mkCompareFields tycon op (dataConOrigArgTys data_con)
450 where
451 data_con_RDR = getRdrName data_con
452 bs_needed = take (dataConSourceArity data_con) bs_RDRs
453
454 mkTagCmp :: OrdOp -> LHsExpr RdrName
455 -- Both constructors known to be nullary
456 -- genreates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#
457 mkTagCmp op = untag_Expr tycon [(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $
458 unliftedOrdOp tycon intPrimTy op ah_RDR bh_RDR
459
460 mkCompareFields :: TyCon -> OrdOp -> [Type] -> LHsExpr RdrName
461 -- Generates nested comparisons for (a1,a2...) against (b1,b2,...)
462 -- where the ai,bi have the given types
463 mkCompareFields tycon op tys
464 = go tys as_RDRs bs_RDRs
465 where
466 go [] _ _ = eqResult op
467 go [ty] (a:_) (b:_)
468 | isUnliftedType ty = unliftedOrdOp tycon ty op a b
469 | otherwise = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)
470 go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
471 (ltResult op)
472 (go tys as bs)
473 (gtResult op)
474 go _ _ _ = panic "mkCompareFields"
475
476 -- (mk_compare ty a b) generates
477 -- (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })
478 -- but with suitable special cases for
479 mk_compare ty a b lt eq gt
480 | isUnliftedType ty
481 = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
482 | otherwise
483 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr))
484 [mkHsCaseAlt (nlNullaryConPat ltTag_RDR) lt,
485 mkHsCaseAlt (nlNullaryConPat eqTag_RDR) eq,
486 mkHsCaseAlt (nlNullaryConPat gtTag_RDR) gt]
487 where
488 a_expr = nlHsVar a
489 b_expr = nlHsVar b
490 (lt_op, _, eq_op, _, _) = primOrdOps "Ord" tycon ty
491
492 unliftedOrdOp :: TyCon -> Type -> OrdOp -> RdrName -> RdrName -> LHsExpr RdrName
493 unliftedOrdOp tycon ty op a b
494 = case op of
495 OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
496 ltTag_Expr eqTag_Expr gtTag_Expr
497 OrdLT -> wrap lt_op
498 OrdLE -> wrap le_op
499 OrdGE -> wrap ge_op
500 OrdGT -> wrap gt_op
501 where
502 (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" tycon ty
503 wrap prim_op = genPrimOpApp a_expr prim_op b_expr
504 a_expr = nlHsVar a
505 b_expr = nlHsVar b
506
507 unliftedCompare :: RdrName -> RdrName
508 -> LHsExpr RdrName -> LHsExpr RdrName -- What to cmpare
509 -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName -- Three results
510 -> LHsExpr RdrName
511 -- Return (if a < b then lt else if a == b then eq else gt)
512 unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
513 = nlHsIf (ascribeBool $ genPrimOpApp a_expr lt_op b_expr) lt $
514 -- Test (<) first, not (==), because the latter
515 -- is true less often, so putting it first would
516 -- mean more tests (dynamically)
517 nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt
518 where
519 ascribeBool e = nlExprWithTySig e boolTy
520
521 nlConWildPat :: DataCon -> LPat RdrName
522 -- The pattern (K {})
523 nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con))
524 (RecCon (HsRecFields { rec_flds = []
525 , rec_dotdot = Nothing })))
526
527 {-
528 ************************************************************************
529 * *
530 Enum instances
531 * *
532 ************************************************************************
533
534 @Enum@ can only be derived for enumeration types. For a type
535 \begin{verbatim}
536 data Foo ... = N1 | N2 | ... | Nn
537 \end{verbatim}
538
539 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
540 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
541
542 \begin{verbatim}
543 instance ... Enum (Foo ...) where
544 succ x = toEnum (1 + fromEnum x)
545 pred x = toEnum (fromEnum x - 1)
546
547 toEnum i = tag2con_Foo i
548
549 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
550
551 -- or, really...
552 enumFrom a
553 = case con2tag_Foo a of
554 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
555
556 enumFromThen a b
557 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
558
559 -- or, really...
560 enumFromThen a b
561 = case con2tag_Foo a of { a# ->
562 case con2tag_Foo b of { b# ->
563 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
564 }}
565 \end{verbatim}
566
567 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
568 -}
569
570 gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
571 gen_Enum_binds loc tycon
572 = (method_binds, aux_binds)
573 where
574 method_binds = listToBag [
575 succ_enum,
576 pred_enum,
577 to_enum,
578 enum_from,
579 enum_from_then,
580 from_enum
581 ]
582 aux_binds = listToBag $ map DerivAuxBind
583 [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
584
585 occ_nm = getOccString tycon
586
587 succ_enum
588 = mk_easy_FunBind loc succ_RDR [a_Pat] $
589 untag_Expr tycon [(a_RDR, ah_RDR)] $
590 nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
591 nlHsVarApps intDataCon_RDR [ah_RDR]])
592 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
593 (nlHsApp (nlHsVar (tag2con_RDR tycon))
594 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
595 nlHsIntLit 1]))
596
597 pred_enum
598 = mk_easy_FunBind loc pred_RDR [a_Pat] $
599 untag_Expr tycon [(a_RDR, ah_RDR)] $
600 nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
601 nlHsVarApps intDataCon_RDR [ah_RDR]])
602 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
603 (nlHsApp (nlHsVar (tag2con_RDR tycon))
604 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
605 nlHsLit (HsInt "-1" (-1))]))
606
607 to_enum
608 = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
609 nlHsIf (nlHsApps and_RDR
610 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
611 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
612 (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
613 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
614
615 enum_from
616 = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
617 untag_Expr tycon [(a_RDR, ah_RDR)] $
618 nlHsApps map_RDR
619 [nlHsVar (tag2con_RDR tycon),
620 nlHsPar (enum_from_to_Expr
621 (nlHsVarApps intDataCon_RDR [ah_RDR])
622 (nlHsVar (maxtag_RDR tycon)))]
623
624 enum_from_then
625 = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
626 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
627 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
628 nlHsPar (enum_from_then_to_Expr
629 (nlHsVarApps intDataCon_RDR [ah_RDR])
630 (nlHsVarApps intDataCon_RDR [bh_RDR])
631 (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
632 nlHsVarApps intDataCon_RDR [bh_RDR]])
633 (nlHsIntLit 0)
634 (nlHsVar (maxtag_RDR tycon))
635 ))
636
637 from_enum
638 = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
639 untag_Expr tycon [(a_RDR, ah_RDR)] $
640 (nlHsVarApps intDataCon_RDR [ah_RDR])
641
642 {-
643 ************************************************************************
644 * *
645 Bounded instances
646 * *
647 ************************************************************************
648 -}
649
650 gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
651 gen_Bounded_binds loc tycon
652 | isEnumerationTyCon tycon
653 = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
654 | otherwise
655 = ASSERT(isSingleton data_cons)
656 (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)
657 where
658 data_cons = tyConDataCons tycon
659
660 ----- enum-flavored: ---------------------------
661 min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
662 max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
663
664 data_con_1 = head data_cons
665 data_con_N = last data_cons
666 data_con_1_RDR = getRdrName data_con_1
667 data_con_N_RDR = getRdrName data_con_N
668
669 ----- single-constructor-flavored: -------------
670 arity = dataConSourceArity data_con_1
671
672 min_bound_1con = mkHsVarBind loc minBound_RDR $
673 nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
674 max_bound_1con = mkHsVarBind loc maxBound_RDR $
675 nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
676
677 {-
678 ************************************************************************
679 * *
680 Ix instances
681 * *
682 ************************************************************************
683
684 Deriving @Ix@ is only possible for enumeration types and
685 single-constructor types. We deal with them in turn.
686
687 For an enumeration type, e.g.,
688 \begin{verbatim}
689 data Foo ... = N1 | N2 | ... | Nn
690 \end{verbatim}
691 things go not too differently from @Enum@:
692 \begin{verbatim}
693 instance ... Ix (Foo ...) where
694 range (a, b)
695 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
696
697 -- or, really...
698 range (a, b)
699 = case (con2tag_Foo a) of { a# ->
700 case (con2tag_Foo b) of { b# ->
701 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
702 }}
703
704 -- Generate code for unsafeIndex, because using index leads
705 -- to lots of redundant range tests
706 unsafeIndex c@(a, b) d
707 = case (con2tag_Foo d -# con2tag_Foo a) of
708 r# -> I# r#
709
710 inRange (a, b) c
711 = let
712 p_tag = con2tag_Foo c
713 in
714 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
715
716 -- or, really...
717 inRange (a, b) c
718 = case (con2tag_Foo a) of { a_tag ->
719 case (con2tag_Foo b) of { b_tag ->
720 case (con2tag_Foo c) of { c_tag ->
721 if (c_tag >=# a_tag) then
722 c_tag <=# b_tag
723 else
724 False
725 }}}
726 \end{verbatim}
727 (modulo suitable case-ification to handle the unlifted tags)
728
729 For a single-constructor type (NB: this includes all tuples), e.g.,
730 \begin{verbatim}
731 data Foo ... = MkFoo a b Int Double c c
732 \end{verbatim}
733 we follow the scheme given in Figure~19 of the Haskell~1.2 report
734 (p.~147).
735 -}
736
737 gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
738
739 gen_Ix_binds loc tycon
740 | isEnumerationTyCon tycon
741 = ( enum_ixes
742 , listToBag $ map DerivAuxBind
743 [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
744 | otherwise
745 = (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))
746 where
747 --------------------------------------------------------------
748 enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
749
750 enum_range
751 = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
752 untag_Expr tycon [(a_RDR, ah_RDR)] $
753 untag_Expr tycon [(b_RDR, bh_RDR)] $
754 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
755 nlHsPar (enum_from_to_Expr
756 (nlHsVarApps intDataCon_RDR [ah_RDR])
757 (nlHsVarApps intDataCon_RDR [bh_RDR]))
758
759 enum_index
760 = mk_easy_FunBind loc unsafeIndex_RDR
761 [noLoc (AsPat (noLoc c_RDR)
762 (nlTuplePat [a_Pat, nlWildPat] Boxed)),
763 d_Pat] (
764 untag_Expr tycon [(a_RDR, ah_RDR)] (
765 untag_Expr tycon [(d_RDR, dh_RDR)] (
766 let
767 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
768 in
769 nlHsCase
770 (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
771 [mkHsCaseAlt (nlVarPat c_RDR) rhs]
772 ))
773 )
774
775 -- This produces something like `(ch >= ah) && (ch <= bh)`
776 enum_inRange
777 = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
778 untag_Expr tycon [(a_RDR, ah_RDR)] (
779 untag_Expr tycon [(b_RDR, bh_RDR)] (
780 untag_Expr tycon [(c_RDR, ch_RDR)] (
781 -- This used to use `if`, which interacts badly with RebindableSyntax.
782 -- See #11396.
783 nlHsApps and_RDR
784 [ genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)
785 , genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR)
786 ]
787 )))
788
789 --------------------------------------------------------------
790 single_con_ixes
791 = listToBag [single_con_range, single_con_index, single_con_inRange]
792
793 data_con
794 = case tyConSingleDataCon_maybe tycon of -- just checking...
795 Nothing -> panic "get_Ix_binds"
796 Just dc -> dc
797
798 con_arity = dataConSourceArity data_con
799 data_con_RDR = getRdrName data_con
800
801 as_needed = take con_arity as_RDRs
802 bs_needed = take con_arity bs_RDRs
803 cs_needed = take con_arity cs_RDRs
804
805 con_pat xs = nlConVarPat data_con_RDR xs
806 con_expr = nlHsVarApps data_con_RDR cs_needed
807
808 --------------------------------------------------------------
809 single_con_range
810 = mk_easy_FunBind loc range_RDR
811 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
812 noLoc (mkHsComp ListComp stmts con_expr)
813 where
814 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
815
816 mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
817 (nlHsApp (nlHsVar range_RDR)
818 (mkLHsVarTuple [a,b]))
819
820 ----------------
821 single_con_index
822 = mk_easy_FunBind loc unsafeIndex_RDR
823 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
824 con_pat cs_needed]
825 -- We need to reverse the order we consider the components in
826 -- so that
827 -- range (l,u) !! index (l,u) i == i -- when i is in range
828 -- (from http://haskell.org/onlinereport/ix.html) holds.
829 (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
830 where
831 -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
832 mk_index [] = nlHsIntLit 0
833 mk_index [(l,u,i)] = mk_one l u i
834 mk_index ((l,u,i) : rest)
835 = genOpApp (
836 mk_one l u i
837 ) plus_RDR (
838 genOpApp (
839 (nlHsApp (nlHsVar unsafeRangeSize_RDR)
840 (mkLHsVarTuple [l,u]))
841 ) times_RDR (mk_index rest)
842 )
843 mk_one l u i
844 = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i]
845
846 ------------------
847 single_con_inRange
848 = mk_easy_FunBind loc inRange_RDR
849 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
850 con_pat cs_needed] $
851 if con_arity == 0
852 -- If the product type has no fields, inRange is trivially true
853 -- (see Trac #12853).
854 then true_Expr
855 else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range
856 as_needed bs_needed cs_needed)
857 where
858 in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
859
860 {-
861 ************************************************************************
862 * *
863 Read instances
864 * *
865 ************************************************************************
866
867 Example
868
869 infix 4 %%
870 data T = Int %% Int
871 | T1 { f1 :: Int }
872 | T2 T
873
874 instance Read T where
875 readPrec =
876 parens
877 ( prec 4 (
878 do x <- ReadP.step Read.readPrec
879 expectP (Symbol "%%")
880 y <- ReadP.step Read.readPrec
881 return (x %% y))
882 +++
883 prec (appPrec+1) (
884 -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
885 -- Record construction binds even more tightly than application
886 do expectP (Ident "T1")
887 expectP (Punc '{')
888 expectP (Ident "f1")
889 expectP (Punc '=')
890 x <- ReadP.reset Read.readPrec
891 expectP (Punc '}')
892 return (T1 { f1 = x }))
893 +++
894 prec appPrec (
895 do expectP (Ident "T2")
896 x <- ReadP.step Read.readPrec
897 return (T2 x))
898 )
899
900 readListPrec = readListPrecDefault
901 readList = readListDefault
902
903
904 Note [Use expectP]
905 ~~~~~~~~~~~~~~~~~~
906 Note that we use
907 expectP (Ident "T1")
908 rather than
909 Ident "T1" <- lexP
910 The latter desugares to inline code for matching the Ident and the
911 string, and this can be very voluminous. The former is much more
912 compact. Cf Trac #7258, although that also concerned non-linearity in
913 the occurrence analyser, a separate issue.
914
915 Note [Read for empty data types]
916 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
917 What should we get for this? (Trac #7931)
918 data Emp deriving( Read ) -- No data constructors
919
920 Here we want
921 read "[]" :: [Emp] to succeed, returning []
922 So we do NOT want
923 instance Read Emp where
924 readPrec = error "urk"
925 Rather we want
926 instance Read Emp where
927 readPred = pfail -- Same as choose []
928
929 Because 'pfail' allows the parser to backtrack, but 'error' doesn't.
930 These instances are also useful for Read (Either Int Emp), where
931 we want to be able to parse (Left 3) just fine.
932 -}
933
934 gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
935
936 gen_Read_binds get_fixity loc tycon
937 = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
938 where
939 -----------------------------------------------------------------------
940 default_readlist
941 = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
942
943 default_readlistprec
944 = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
945 -----------------------------------------------------------------------
946
947 data_cons = tyConDataCons tycon
948 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
949
950 read_prec = mkHsVarBind loc readPrec_RDR
951 (nlHsApp (nlHsVar parens_RDR) read_cons)
952
953 read_cons | null data_cons = nlHsVar pfail_RDR -- See Note [Read for empty data types]
954 | otherwise = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
955 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
956
957 read_nullary_cons
958 = case nullary_cons of
959 [] -> []
960 [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])]
961 _ -> [nlHsApp (nlHsVar choose_RDR)
962 (nlList (map mk_pair nullary_cons))]
963 -- NB For operators the parens around (:=:) are matched by the
964 -- enclosing "parens" call, so here we must match the naked
965 -- data_con_str con
966
967 match_con con | isSym con_str = [symbol_pat con_str]
968 | otherwise = ident_h_pat con_str
969 where
970 con_str = data_con_str con
971 -- For nullary constructors we must match Ident s for normal constrs
972 -- and Symbol s for operators
973
974 mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),
975 result_expr con []]
976
977 read_non_nullary_con data_con
978 | is_infix = mk_parser infix_prec infix_stmts body
979 | is_record = mk_parser record_prec record_stmts body
980 -- Using these two lines instead allows the derived
981 -- read for infix and record bindings to read the prefix form
982 -- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body)
983 -- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
984 | otherwise = prefix_parser
985 where
986 body = result_expr data_con as_needed
987 con_str = data_con_str data_con
988
989 prefix_parser = mk_parser prefix_prec prefix_stmts body
990
991 read_prefix_con
992 | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"]
993 | otherwise = ident_h_pat con_str
994
995 read_infix_con
996 | isSym con_str = [symbol_pat con_str]
997 | otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"]
998
999 prefix_stmts -- T a b c
1000 = read_prefix_con ++ read_args
1001
1002 infix_stmts -- a %% b, or a `T` b
1003 = [read_a1]
1004 ++ read_infix_con
1005 ++ [read_a2]
1006
1007 record_stmts -- T { f1 = a, f2 = b }
1008 = read_prefix_con
1009 ++ [read_punc "{"]
1010 ++ concat (intersperse [read_punc ","] field_stmts)
1011 ++ [read_punc "}"]
1012
1013 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
1014
1015 con_arity = dataConSourceArity data_con
1016 labels = map flLabel $ dataConFieldLabels data_con
1017 dc_nm = getName data_con
1018 is_infix = dataConIsInfix data_con
1019 is_record = length labels > 0
1020 as_needed = take con_arity as_RDRs
1021 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
1022 (read_a1:read_a2:_) = read_args
1023
1024 prefix_prec = appPrecedence
1025 infix_prec = getPrecedence get_fixity dc_nm
1026 record_prec = appPrecedence + 1 -- Record construction binds even more tightly
1027 -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
1028
1029 ------------------------------------------------------------------------
1030 -- Helpers
1031 ------------------------------------------------------------------------
1032 mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
1033 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b })
1034 , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])]
1035 con_app con as = nlHsVarApps (getRdrName con) as -- con as
1036 result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
1037
1038 -- For constructors and field labels ending in '#', we hackily
1039 -- let the lexer generate two tokens, and look for both in sequence
1040 -- Thus [Ident "I"; Symbol "#"]. See Trac #5041
1041 ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ]
1042 | otherwise = [ ident_pat s ]
1043
1044 bindLex pat = noLoc (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat)) -- expectP p
1045 -- See Note [Use expectP]
1046 ident_pat s = bindLex $ nlHsApps ident_RDR [nlHsLit (mkHsString s)] -- expectP (Ident "foo")
1047 symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)] -- expectP (Symbol ">>")
1048 read_punc c = bindLex $ nlHsApps punc_RDR [nlHsLit (mkHsString c)] -- expectP (Punc "<")
1049
1050 data_con_str con = occNameString (getOccName con)
1051
1052 read_arg a ty = ASSERT( not (isUnliftedType ty) )
1053 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
1054
1055 read_field lbl a = read_lbl lbl ++
1056 [read_punc "=",
1057 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
1058
1059 -- When reading field labels we might encounter
1060 -- a = 3
1061 -- _a = 3
1062 -- or (#) = 4
1063 -- Note the parens!
1064 read_lbl lbl | isSym lbl_str
1065 = [read_punc "(", symbol_pat lbl_str, read_punc ")"]
1066 | otherwise
1067 = ident_h_pat lbl_str
1068 where
1069 lbl_str = unpackFS lbl
1070
1071 {-
1072 ************************************************************************
1073 * *
1074 Show instances
1075 * *
1076 ************************************************************************
1077
1078 Example
1079
1080 infixr 5 :^:
1081
1082 data Tree a = Leaf a | Tree a :^: Tree a
1083
1084 instance (Show a) => Show (Tree a) where
1085
1086 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
1087 where
1088 showStr = showString "Leaf " . showsPrec (app_prec+1) m
1089
1090 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
1091 where
1092 showStr = showsPrec (up_prec+1) u .
1093 showString " :^: " .
1094 showsPrec (up_prec+1) v
1095 -- Note: right-associativity of :^: ignored
1096
1097 up_prec = 5 -- Precedence of :^:
1098 app_prec = 10 -- Application has precedence one more than
1099 -- the most tightly-binding operator
1100 -}
1101
1102 gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1103
1104 gen_Show_binds get_fixity loc tycon
1105 = (listToBag [shows_prec, show_list], emptyBag)
1106 where
1107 -----------------------------------------------------------------------
1108 show_list = mkHsVarBind loc showList_RDR
1109 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
1110 -----------------------------------------------------------------------
1111 data_cons = tyConDataCons tycon
1112 shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc data_cons)
1113
1114 pats_etc data_con
1115 | nullary_con = -- skip the showParen junk...
1116 ASSERT(null bs_needed)
1117 ([nlWildPat, con_pat], mk_showString_app op_con_str)
1118 | otherwise =
1119 ([a_Pat, con_pat],
1120 showParen_Expr (genOpApp a_Expr ge_RDR
1121 (nlHsLit (HsInt "" con_prec_plus_one)))
1122 (nlHsPar (nested_compose_Expr show_thingies)))
1123 where
1124 data_con_RDR = getRdrName data_con
1125 con_arity = dataConSourceArity data_con
1126 bs_needed = take con_arity bs_RDRs
1127 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
1128 con_pat = nlConVarPat data_con_RDR bs_needed
1129 nullary_con = con_arity == 0
1130 labels = map flLabel $ dataConFieldLabels data_con
1131 lab_fields = length labels
1132 record_syntax = lab_fields > 0
1133
1134 dc_nm = getName data_con
1135 dc_occ_nm = getOccName data_con
1136 con_str = occNameString dc_occ_nm
1137 op_con_str = wrapOpParens con_str
1138 backquote_str = wrapOpBackquotes con_str
1139
1140 show_thingies
1141 | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
1142 | record_syntax = mk_showString_app (op_con_str ++ " {") :
1143 show_record_args ++ [mk_showString_app "}"]
1144 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
1145
1146 show_label l = mk_showString_app (nm ++ " = ")
1147 -- Note the spaces around the "=" sign. If we
1148 -- don't have them then we get Foo { x=-1 } and
1149 -- the "=-" parses as a single lexeme. Only the
1150 -- space after the '=' is necessary, but it
1151 -- seems tidier to have them both sides.
1152 where
1153 nm = wrapOpParens (unpackFS l)
1154
1155 show_args = zipWith show_arg bs_needed arg_tys
1156 (show_arg1:show_arg2:_) = show_args
1157 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
1158
1159 -- Assumption for record syntax: no of fields == no of
1160 -- labelled fields (and in same order)
1161 show_record_args = concat $
1162 intersperse [mk_showString_app ", "] $
1163 [ [show_label lbl, arg]
1164 | (lbl,arg) <- zipEqual "gen_Show_binds"
1165 labels show_args ]
1166
1167 show_arg :: RdrName -> Type -> LHsExpr RdrName
1168 show_arg b arg_ty
1169 | isUnliftedType arg_ty
1170 -- See Note [Deriving and unboxed types] in TcDeriv
1171 = nlHsApps compose_RDR [mk_shows_app boxed_arg,
1172 mk_showString_app postfixMod]
1173 | otherwise
1174 = mk_showsPrec_app arg_prec arg
1175 where
1176 arg = nlHsVar b
1177 boxed_arg = box "Show" tycon arg arg_ty
1178 postfixMod = assoc_ty_id "Show" tycon postfixModTbl arg_ty
1179
1180 -- Fixity stuff
1181 is_infix = dataConIsInfix data_con
1182 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1183 arg_prec | record_syntax = 0 -- Record fields don't need parens
1184 | otherwise = con_prec_plus_one
1185
1186 wrapOpParens :: String -> String
1187 wrapOpParens s | isSym s = '(' : s ++ ")"
1188 | otherwise = s
1189
1190 wrapOpBackquotes :: String -> String
1191 wrapOpBackquotes s | isSym s = s
1192 | otherwise = '`' : s ++ "`"
1193
1194 isSym :: String -> Bool
1195 isSym "" = False
1196 isSym (c : _) = startsVarSym c || startsConSym c
1197
1198 -- | showString :: String -> ShowS
1199 mk_showString_app :: String -> LHsExpr RdrName
1200 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1201
1202 -- | showsPrec :: Show a => Int -> a -> ShowS
1203 mk_showsPrec_app :: Integer -> LHsExpr RdrName -> LHsExpr RdrName
1204 mk_showsPrec_app p x = nlHsApps showsPrec_RDR [nlHsLit (HsInt "" p), x]
1205
1206 -- | shows :: Show a => a -> ShowS
1207 mk_shows_app :: LHsExpr RdrName -> LHsExpr RdrName
1208 mk_shows_app x = nlHsApp (nlHsVar shows_RDR) x
1209
1210 getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer
1211 getPrec is_infix get_fixity nm
1212 | not is_infix = appPrecedence
1213 | otherwise = getPrecedence get_fixity nm
1214
1215 appPrecedence :: Integer
1216 appPrecedence = fromIntegral maxPrecedence + 1
1217 -- One more than the precedence of the most
1218 -- tightly-binding operator
1219
1220 getPrecedence :: (Name -> Fixity) -> Name -> Integer
1221 getPrecedence get_fixity nm
1222 = case get_fixity nm of
1223 Fixity _ x _assoc -> fromIntegral x
1224 -- NB: the Report says that associativity is not taken
1225 -- into account for either Read or Show; hence we
1226 -- ignore associativity here
1227
1228 {-
1229 ************************************************************************
1230 * *
1231 Data instances
1232 * *
1233 ************************************************************************
1234
1235 From the data type
1236
1237 data T a b = T1 a b | T2
1238
1239 we generate
1240
1241 $cT1 = mkDataCon $dT "T1" Prefix
1242 $cT2 = mkDataCon $dT "T2" Prefix
1243 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1244 -- the [] is for field labels.
1245
1246 instance (Data a, Data b) => Data (T a b) where
1247 gfoldl k z (T1 a b) = z T `k` a `k` b
1248 gfoldl k z T2 = z T2
1249 -- ToDo: add gmapT,Q,M, gfoldr
1250
1251 gunfold k z c = case conIndex c of
1252 I# 1# -> k (k (z T1))
1253 I# 2# -> z T2
1254
1255 toConstr (T1 _ _) = $cT1
1256 toConstr T2 = $cT2
1257
1258 dataTypeOf _ = $dT
1259
1260 dataCast1 = gcast1 -- If T :: * -> *
1261 dataCast2 = gcast2 -- if T :: * -> * -> *
1262 -}
1263
1264 gen_Data_binds :: SrcSpan
1265 -> TyCon -- For data families, this is the
1266 -- *representation* TyCon
1267 -> TcM (LHsBinds RdrName, -- The method bindings
1268 BagDerivStuff) -- Auxiliary bindings
1269 gen_Data_binds loc rep_tc
1270 = do { dflags <- getDynFlags
1271
1272 -- Make unique names for the data type and constructor
1273 -- auxiliary bindings. Start with the name of the TyCon/DataCon
1274 -- but that might not be unique: see Trac #12245.
1275 ; dt_occ <- chooseUniqueOccTc (mkDataTOcc (getOccName rep_tc))
1276 ; dc_occs <- mapM (chooseUniqueOccTc . mkDataCOcc . getOccName)
1277 (tyConDataCons rep_tc)
1278 ; let dt_rdr = mkRdrUnqual dt_occ
1279 dc_rdrs = map mkRdrUnqual dc_occs
1280
1281 -- OK, now do the work
1282 ; return (gen_data dflags dt_rdr dc_rdrs loc rep_tc) }
1283
1284 gen_data :: DynFlags -> RdrName -> [RdrName]
1285 -> SrcSpan -> TyCon
1286 -> (LHsBinds RdrName, -- The method bindings
1287 BagDerivStuff) -- Auxiliary bindings
1288 gen_data dflags data_type_name constr_names loc rep_tc
1289 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
1290 `unionBags` gcast_binds,
1291 -- Auxiliary definitions: the data type and constructors
1292 listToBag ( genDataTyCon
1293 : zipWith genDataDataCon data_cons constr_names ) )
1294 where
1295 data_cons = tyConDataCons rep_tc
1296 n_cons = length data_cons
1297 one_constr = n_cons == 1
1298 genDataTyCon :: DerivStuff
1299 genDataTyCon -- $dT
1300 = DerivHsBind (mkHsVarBind loc data_type_name rhs,
1301 L loc (TypeSig [L loc data_type_name] sig_ty))
1302
1303 sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR)
1304 rhs = nlHsVar mkDataType_RDR
1305 `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc)))
1306 `nlHsApp` nlList (map nlHsVar constr_names)
1307
1308 genDataDataCon :: DataCon -> RdrName -> DerivStuff
1309 genDataDataCon dc constr_name -- $cT1 etc
1310 = DerivHsBind (mkHsVarBind loc constr_name rhs,
1311 L loc (TypeSig [L loc constr_name] sig_ty))
1312 where
1313 sig_ty = mkLHsSigWcType (nlHsTyVar constr_RDR)
1314 rhs = nlHsApps mkConstr_RDR constr_args
1315
1316 constr_args
1317 = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1318 nlHsVar (data_type_name) -- DataType
1319 , nlHsLit (mkHsString (occNameString dc_occ)) -- String name
1320 , nlList labels -- Field labels
1321 , nlHsVar fixity ] -- Fixity
1322
1323 labels = map (nlHsLit . mkHsString . unpackFS . flLabel)
1324 (dataConFieldLabels dc)
1325 dc_occ = getOccName dc
1326 is_infix = isDataSymOcc dc_occ
1327 fixity | is_infix = infix_RDR
1328 | otherwise = prefix_RDR
1329
1330 ------------ gfoldl
1331 gfoldl_bind = mk_HRFunBind 2 loc gfoldl_RDR (map gfoldl_eqn data_cons)
1332
1333 gfoldl_eqn con
1334 = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1335 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1336 where
1337 con_name :: RdrName
1338 con_name = getRdrName con
1339 as_needed = take (dataConSourceArity con) as_RDRs
1340 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1341
1342 ------------ gunfold
1343 gunfold_bind = mk_HRFunBind 2 loc
1344 gunfold_RDR
1345 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1346 gunfold_rhs)]
1347
1348 gunfold_rhs
1349 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1350 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1351 (map gunfold_alt data_cons)
1352
1353 gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1354 mk_unfold_rhs dc = foldr nlHsApp
1355 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1356 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1357
1358 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1359 -- redundant test, and annoying warning
1360 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1361 | otherwise = nlConPat intDataCon_RDR
1362 [nlLitPat (HsIntPrim "" (toInteger tag))]
1363 where
1364 tag = dataConTag dc
1365
1366 ------------ toConstr
1367 toCon_bind = mk_FunBind loc toConstr_RDR (zipWith to_con_eqn data_cons constr_names)
1368 to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name)
1369
1370 ------------ dataTypeOf
1371 dataTypeOf_bind = mk_easy_FunBind
1372 loc
1373 dataTypeOf_RDR
1374 [nlWildPat]
1375 (nlHsVar data_type_name)
1376
1377 ------------ gcast1/2
1378 -- Make the binding dataCast1 x = gcast1 x -- if T :: * -> *
1379 -- or dataCast2 x = gcast2 s -- if T :: * -> * -> *
1380 -- (or nothing if T has neither of these two types)
1381
1382 -- But care is needed for data families:
1383 -- If we have data family D a
1384 -- data instance D (a,b,c) = A | B deriving( Data )
1385 -- and we want instance ... => Data (D [(a,b,c)]) where ...
1386 -- then we need dataCast1 x = gcast1 x
1387 -- because D :: * -> *
1388 -- even though rep_tc has kind * -> * -> * -> *
1389 -- Hence looking for the kind of fam_tc not rep_tc
1390 -- See Trac #4896
1391 tycon_kind = case tyConFamInst_maybe rep_tc of
1392 Just (fam_tc, _) -> tyConKind fam_tc
1393 Nothing -> tyConKind rep_tc
1394 gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR
1395 | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
1396 | otherwise = emptyBag
1397 mk_gcast dataCast_RDR gcast_RDR
1398 = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
1399 (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
1400
1401
1402 kind1, kind2 :: Kind
1403 kind1 = liftedTypeKind `mkFunTy` liftedTypeKind
1404 kind2 = liftedTypeKind `mkFunTy` kind1
1405
1406 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
1407 mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
1408 dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,
1409 constr_RDR, dataType_RDR,
1410 eqChar_RDR , ltChar_RDR , geChar_RDR , gtChar_RDR , leChar_RDR ,
1411 eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR ,
1412 eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR ,
1413 eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR ,
1414 eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,
1415 eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR :: RdrName
1416 gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
1417 gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
1418 toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
1419 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1420 dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1")
1421 dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2")
1422 gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1")
1423 gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2")
1424 mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
1425 constr_RDR = tcQual_RDR gENERICS (fsLit "Constr")
1426 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1427 dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType")
1428 conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
1429 prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix")
1430 infix_RDR = dataQual_RDR gENERICS (fsLit "Infix")
1431
1432 eqChar_RDR = varQual_RDR gHC_PRIM (fsLit "eqChar#")
1433 ltChar_RDR = varQual_RDR gHC_PRIM (fsLit "ltChar#")
1434 leChar_RDR = varQual_RDR gHC_PRIM (fsLit "leChar#")
1435 gtChar_RDR = varQual_RDR gHC_PRIM (fsLit "gtChar#")
1436 geChar_RDR = varQual_RDR gHC_PRIM (fsLit "geChar#")
1437
1438 eqInt_RDR = varQual_RDR gHC_PRIM (fsLit "==#")
1439 ltInt_RDR = varQual_RDR gHC_PRIM (fsLit "<#" )
1440 leInt_RDR = varQual_RDR gHC_PRIM (fsLit "<=#")
1441 gtInt_RDR = varQual_RDR gHC_PRIM (fsLit ">#" )
1442 geInt_RDR = varQual_RDR gHC_PRIM (fsLit ">=#")
1443
1444 eqWord_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord#")
1445 ltWord_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord#")
1446 leWord_RDR = varQual_RDR gHC_PRIM (fsLit "leWord#")
1447 gtWord_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord#")
1448 geWord_RDR = varQual_RDR gHC_PRIM (fsLit "geWord#")
1449
1450 eqAddr_RDR = varQual_RDR gHC_PRIM (fsLit "eqAddr#")
1451 ltAddr_RDR = varQual_RDR gHC_PRIM (fsLit "ltAddr#")
1452 leAddr_RDR = varQual_RDR gHC_PRIM (fsLit "leAddr#")
1453 gtAddr_RDR = varQual_RDR gHC_PRIM (fsLit "gtAddr#")
1454 geAddr_RDR = varQual_RDR gHC_PRIM (fsLit "geAddr#")
1455
1456 eqFloat_RDR = varQual_RDR gHC_PRIM (fsLit "eqFloat#")
1457 ltFloat_RDR = varQual_RDR gHC_PRIM (fsLit "ltFloat#")
1458 leFloat_RDR = varQual_RDR gHC_PRIM (fsLit "leFloat#")
1459 gtFloat_RDR = varQual_RDR gHC_PRIM (fsLit "gtFloat#")
1460 geFloat_RDR = varQual_RDR gHC_PRIM (fsLit "geFloat#")
1461
1462 eqDouble_RDR = varQual_RDR gHC_PRIM (fsLit "==##")
1463 ltDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<##" )
1464 leDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<=##")
1465 gtDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">##" )
1466 geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##")
1467
1468 {-
1469 ************************************************************************
1470 * *
1471 Lift instances
1472 * *
1473 ************************************************************************
1474
1475 Example:
1476
1477 data Foo a = Foo a | a :^: a deriving Lift
1478
1479 ==>
1480
1481 instance (Lift a) => Lift (Foo a) where
1482 lift (Foo a)
1483 = appE
1484 (conE
1485 (mkNameG_d "package-name" "ModuleName" "Foo"))
1486 (lift a)
1487 lift (u :^: v)
1488 = infixApp
1489 (lift u)
1490 (conE
1491 (mkNameG_d "package-name" "ModuleName" ":^:"))
1492 (lift v)
1493
1494 Note that (mkNameG_d "package-name" "ModuleName" "Foo") is equivalent to what
1495 'Foo would be when using the -XTemplateHaskell extension. To make sure that
1496 -XDeriveLift can be used on stage-1 compilers, however, we expliticly invoke
1497 makeG_d.
1498 -}
1499
1500 gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1501 gen_Lift_binds loc tycon
1502 | null data_cons = (unitBag (L loc $ mkFunBind (L loc lift_RDR)
1503 [mkMatch (FunRhs (L loc lift_RDR) Prefix)
1504 [nlWildPat] errorMsg_Expr
1505 (noLoc emptyLocalBinds)])
1506 , emptyBag)
1507 | otherwise = (unitBag lift_bind, emptyBag)
1508 where
1509 errorMsg_Expr = nlHsVar error_RDR `nlHsApp` nlHsLit
1510 (mkHsString $ "Can't lift value of empty datatype " ++ tycon_str)
1511
1512 lift_bind = mk_FunBind loc lift_RDR (map pats_etc data_cons)
1513 data_cons = tyConDataCons tycon
1514 tycon_str = occNameString . nameOccName . tyConName $ tycon
1515
1516 pats_etc data_con
1517 = ([con_pat], lift_Expr)
1518 where
1519 con_pat = nlConVarPat data_con_RDR as_needed
1520 data_con_RDR = getRdrName data_con
1521 con_arity = dataConSourceArity data_con
1522 as_needed = take con_arity as_RDRs
1523 lifted_as = zipWithEqual "mk_lift_app" mk_lift_app
1524 tys_needed as_needed
1525 tycon_name = tyConName tycon
1526 is_infix = dataConIsInfix data_con
1527 tys_needed = dataConOrigArgTys data_con
1528
1529 mk_lift_app ty a
1530 | not (isUnliftedType ty) = nlHsApp (nlHsVar lift_RDR)
1531 (nlHsVar a)
1532 | otherwise = nlHsApp (nlHsVar litE_RDR)
1533 (primLitOp (mkBoxExp (nlHsVar a)))
1534 where (primLitOp, mkBoxExp) = primLitOps "Lift" tycon ty
1535
1536 pkg_name = unitIdString . moduleUnitId
1537 . nameModule $ tycon_name
1538 mod_name = moduleNameString . moduleName . nameModule $ tycon_name
1539 con_name = occNameString . nameOccName . dataConName $ data_con
1540
1541 conE_Expr = nlHsApp (nlHsVar conE_RDR)
1542 (nlHsApps mkNameG_dRDR
1543 (map (nlHsLit . mkHsString)
1544 [pkg_name, mod_name, con_name]))
1545
1546 lift_Expr
1547 | is_infix = nlHsApps infixApp_RDR [a1, conE_Expr, a2]
1548 | otherwise = foldl mk_appE_app conE_Expr lifted_as
1549 (a1:a2:_) = lifted_as
1550
1551 mk_appE_app :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1552 mk_appE_app a b = nlHsApps appE_RDR [a, b]
1553
1554 {-
1555 ************************************************************************
1556 * *
1557 Newtype-deriving instances
1558 * *
1559 ************************************************************************
1560
1561 Note [Newtype-deriving instances]
1562 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1563 We take every method in the original instance and `coerce` it to fit
1564 into the derived instance. We need a type annotation on the argument
1565 to `coerce` to make it obvious what instantiation of the method we're
1566 coercing from. So from, say,
1567 class C a b where
1568 op :: a -> [b] -> Int
1569
1570 newtype T x = MkT <rep-ty>
1571
1572 instance C a <rep-ty> => C a (T x) where
1573 op = coerce @ (a -> [<rep-ty>] -> Int)
1574 @ (a -> [T x] -> Int)
1575 op
1576
1577 Notice that we give the 'coerce' two explicitly-visible type arguments
1578 to say how it should be instantiated. Recall
1579
1580 coerce :: Coeercible a b => a -> b
1581
1582 By giving it explicit type arguments we deal with the case where
1583 'op' has a higher rank type, and so we must instantiate 'coerce' with
1584 a polytype. E.g.
1585 class C a where op :: forall b. a -> b -> b
1586 newtype T x = MkT <rep-ty>
1587 instance C <rep-ty> => C (T x) where
1588 op = coerce @ (forall b. <rep-ty> -> b -> b)
1589 @ (forall b. T x -> b -> b)
1590 op
1591
1592 The type checker checks this code, and it currently requires
1593 -XImpredicativeTypes to permit that polymorphic type instantiation,
1594 so we have to switch that flag on locally in TcDeriv.genInst.
1595
1596 See #8503 for more discussion.
1597
1598 Note [Newtype-deriving trickiness]
1599 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1600 Consider (Trac #12768):
1601 class C a where { op :: D a => a -> a }
1602
1603 instance C a => C [a] where { op = opList }
1604
1605 opList :: (C a, D [a]) => [a] -> [a]
1606 opList = ...
1607
1608 Now suppose we try GND on this:
1609 newtype N a = MkN [a] deriving( C )
1610
1611 The GND is expecting to get an implementation of op for N by
1612 coercing opList, thus:
1613
1614 instance C a => C (N a) where { op = opN }
1615
1616 opN :: (C a, D (N a)) => N a -> N a
1617 opN = coerce @(D [a] => [a] -> [a])
1618 @(D (N a) => [N a] -> [N a]
1619 opList
1620
1621 But there is no reason to suppose that (D [a]) and (D (N a))
1622 are inter-coercible; these instances might completely different.
1623 So GHC rightly rejects this code.
1624 -}
1625
1626 gen_Newtype_binds :: SrcSpan
1627 -> Class -- the class being derived
1628 -> [TyVar] -- the tvs in the instance head (this includes
1629 -- the tvs from both the class types and the
1630 -- newtype itself)
1631 -> [Type] -- instance head parameters (incl. newtype)
1632 -> Type -- the representation type
1633 -> TcM (LHsBinds RdrName, BagDerivStuff)
1634 -- See Note [Newtype-deriving instances]
1635 gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
1636 = do let ats = classATs cls
1637 atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats )
1638 mapM mk_atf_inst ats
1639 return ( listToBag $ map mk_bind (classMethods cls)
1640 , listToBag $ map DerivFamInst atf_insts )
1641 where
1642 coerce_RDR = getRdrName coerceId
1643
1644 mk_bind :: Id -> LHsBind RdrName
1645 mk_bind meth_id
1646 = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch
1647 (FunRhs (L loc meth_RDR) Prefix)
1648 [] rhs_expr]
1649 where
1650 Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id
1651
1652 meth_RDR = getRdrName meth_id
1653
1654 rhs_expr = nlHsVar coerce_RDR `nlHsAppType` from_ty
1655 `nlHsAppType` to_ty
1656 `nlHsApp` nlHsVar meth_RDR
1657
1658 mk_atf_inst :: TyCon -> TcM FamInst
1659 mk_atf_inst fam_tc = do
1660 rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc))
1661 rep_lhs_tys
1662 let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' rep_cvs'
1663 fam_tc rep_lhs_tys rep_rhs_ty
1664 -- Check (c) from Note [GND and associated type families] in TcDeriv
1665 checkValidTyFamEqn (Just (cls, cls_tvs, lhs_env)) fam_tc rep_tvs'
1666 rep_cvs' rep_lhs_tys rep_rhs_ty loc
1667 newFamInst SynFamilyInst axiom
1668 where
1669 cls_tvs = classTyVars cls
1670 in_scope = mkInScopeSet $ mkVarSet inst_tvs
1671 lhs_env = zipTyEnv cls_tvs inst_tys
1672 lhs_subst = mkTvSubst in_scope lhs_env
1673 rhs_env = zipTyEnv cls_tvs $ changeLast inst_tys rhs_ty
1674 rhs_subst = mkTvSubst in_scope rhs_env
1675 fam_tvs = tyConTyVars fam_tc
1676 rep_lhs_tys = substTyVars lhs_subst fam_tvs
1677 rep_rhs_tys = substTyVars rhs_subst fam_tvs
1678 rep_rhs_ty = mkTyConApp fam_tc rep_rhs_tys
1679 rep_tcvs = tyCoVarsOfTypesList rep_lhs_tys
1680 (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs
1681 rep_tvs' = toposortTyVars rep_tvs
1682 rep_cvs' = toposortTyVars rep_cvs
1683
1684 nlHsAppType :: LHsExpr RdrName -> Type -> LHsExpr RdrName
1685 nlHsAppType e s = noLoc (e `HsAppType` hs_ty)
1686 where
1687 hs_ty = mkHsWildCardBndrs (typeToLHsType s)
1688
1689 nlExprWithTySig :: LHsExpr RdrName -> Type -> LHsExpr RdrName
1690 nlExprWithTySig e s = noLoc (e `ExprWithTySig` hs_ty)
1691 where
1692 hs_ty = mkLHsSigWcType (typeToLHsType s)
1693
1694 mkCoerceClassMethEqn :: Class -- the class being derived
1695 -> [TyVar] -- the tvs in the instance head (this includes
1696 -- the tvs from both the class types and the
1697 -- newtype itself)
1698 -> [Type] -- instance head parameters (incl. newtype)
1699 -> Type -- the representation type
1700 -> Id -- the method to look at
1701 -> Pair Type
1702 -- See Note [Newtype-deriving instances]
1703 -- See also Note [Newtype-deriving trickiness]
1704 -- The pair is the (from_type, to_type), where to_type is
1705 -- the type of the method we are tyrying to get
1706 mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty id
1707 = Pair (substTy rhs_subst user_meth_ty)
1708 (substTy lhs_subst user_meth_ty)
1709 where
1710 cls_tvs = classTyVars cls
1711 in_scope = mkInScopeSet $ mkVarSet inst_tvs
1712 lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs inst_tys)
1713 rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast inst_tys rhs_ty))
1714 (_class_tvs, _class_constraint, user_meth_ty)
1715 = tcSplitMethodTy (varType id)
1716
1717 {-
1718 ************************************************************************
1719 * *
1720 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1721 * *
1722 ************************************************************************
1723
1724 \begin{verbatim}
1725 data Foo ... = ...
1726
1727 con2tag_Foo :: Foo ... -> Int#
1728 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1729 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1730 \end{verbatim}
1731
1732 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1733 fiddling around.
1734 -}
1735
1736 genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName)
1737 genAuxBindSpec loc (DerivCon2Tag tycon)
1738 = (mk_FunBind loc rdr_name eqns,
1739 L loc (TypeSig [L loc rdr_name] sig_ty))
1740 where
1741 rdr_name = con2tag_RDR tycon
1742
1743 sig_ty = mkLHsSigWcType $ L loc $ HsCoreTy $
1744 mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
1745 mkParentType tycon `mkFunTy` intPrimTy
1746
1747 lots_of_constructors = tyConFamilySize tycon > 8
1748 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1749 -- but we don't do vectored returns any more.
1750
1751 eqns | lots_of_constructors = [get_tag_eqn]
1752 | otherwise = map mk_eqn (tyConDataCons tycon)
1753
1754 get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
1755
1756 mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1757 mk_eqn con = ([nlWildConPat con],
1758 nlHsLit (HsIntPrim ""
1759 (toInteger ((dataConTag con) - fIRST_TAG))))
1760
1761 genAuxBindSpec loc (DerivTag2Con tycon)
1762 = (mk_FunBind loc rdr_name
1763 [([nlConVarPat intDataCon_RDR [a_RDR]],
1764 nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
1765 L loc (TypeSig [L loc rdr_name] sig_ty))
1766 where
1767 sig_ty = mkLHsSigWcType $ L loc $
1768 HsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
1769 intTy `mkFunTy` mkParentType tycon
1770
1771 rdr_name = tag2con_RDR tycon
1772
1773 genAuxBindSpec loc (DerivMaxTag tycon)
1774 = (mkHsVarBind loc rdr_name rhs,
1775 L loc (TypeSig [L loc rdr_name] sig_ty))
1776 where
1777 rdr_name = maxtag_RDR tycon
1778 sig_ty = mkLHsSigWcType (L loc (HsCoreTy intTy))
1779 rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim "" max_tag))
1780 max_tag = case (tyConDataCons tycon) of
1781 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1782
1783 type SeparateBagsDerivStuff =
1784 -- AuxBinds and SYB bindings
1785 ( Bag (LHsBind RdrName, LSig RdrName)
1786 -- Extra family instances (used by Generic and DeriveAnyClass)
1787 , Bag (FamInst) )
1788
1789 genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
1790 genAuxBinds loc b = genAuxBinds' b2 where
1791 (b1,b2) = partitionBagWith splitDerivAuxBind b
1792 splitDerivAuxBind (DerivAuxBind x) = Left x
1793 splitDerivAuxBind x = Right x
1794
1795 rm_dups = foldrBag dup_check emptyBag
1796 dup_check a b = if anyBag (== a) b then b else consBag a b
1797
1798 genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
1799 genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec loc) (rm_dups b1)
1800 , emptyBag )
1801 f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
1802 f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
1803 f (DerivHsBind b) = add1 b
1804 f (DerivFamInst t) = add2 t
1805
1806 add1 x (a,b) = (x `consBag` a,b)
1807 add2 x (a,b) = (a,x `consBag` b)
1808
1809 mkParentType :: TyCon -> Type
1810 -- Turn the representation tycon of a family into
1811 -- a use of its family constructor
1812 mkParentType tc
1813 = case tyConFamInst_maybe tc of
1814 Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
1815 Just (fam_tc,tys) -> mkTyConApp fam_tc tys
1816
1817 {-
1818 ************************************************************************
1819 * *
1820 \subsection{Utility bits for generating bindings}
1821 * *
1822 ************************************************************************
1823 -}
1824
1825 mk_FunBind :: SrcSpan -> RdrName
1826 -> [([LPat RdrName], LHsExpr RdrName)]
1827 -> LHsBind RdrName
1828 mk_FunBind = mk_HRFunBind 0 -- by using mk_FunBind and not mk_HRFunBind,
1829 -- the caller says that the Void case needs no
1830 -- patterns
1831
1832 -- | This variant of 'mk_FunBind' puts an 'Arity' number of wildcards before
1833 -- the "=" in the empty-data-decl case. This is necessary if the function
1834 -- has a higher-rank type, like foldl. (See deriving/should_compile/T4302)
1835 mk_HRFunBind :: Arity -> SrcSpan -> RdrName
1836 -> [([LPat RdrName], LHsExpr RdrName)]
1837 -> LHsBind RdrName
1838 mk_HRFunBind arity loc fun pats_and_exprs
1839 = mkHRRdrFunBind arity (L loc fun) matches
1840 where
1841 matches = [mkMatch (FunRhs (L loc fun) Prefix) p e
1842 (noLoc emptyLocalBinds)
1843 | (p,e) <-pats_and_exprs]
1844
1845 mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
1846 mkRdrFunBind = mkHRRdrFunBind 0
1847
1848 mkHRRdrFunBind :: Arity -> Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
1849 mkHRRdrFunBind arity fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
1850 where
1851 -- Catch-all eqn looks like
1852 -- fmap = error "Void fmap"
1853 -- It's needed if there no data cons at all,
1854 -- which can happen with -XEmptyDataDecls
1855 -- See Trac #4302
1856 matches' = if null matches
1857 then [mkMatch (FunRhs fun Prefix)
1858 (replicate arity nlWildPat)
1859 (error_Expr str) (noLoc emptyLocalBinds)]
1860 else matches
1861 str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
1862
1863 box :: String -- The class involved
1864 -> TyCon -- The tycon involved
1865 -> LHsExpr RdrName -- The argument
1866 -> Type -- The argument type
1867 -> LHsExpr RdrName -- Boxed version of the arg
1868 -- See Note [Deriving and unboxed types] in TcDeriv
1869 box cls_str tycon arg arg_ty = nlHsApp (nlHsVar box_con) arg
1870 where
1871 box_con = assoc_ty_id cls_str tycon boxConTbl arg_ty
1872
1873 ---------------------
1874 primOrdOps :: String -- The class involved
1875 -> TyCon -- The tycon involved
1876 -> Type -- The type
1877 -> (RdrName, RdrName, RdrName, RdrName, RdrName) -- (lt,le,eq,ge,gt)
1878 -- See Note [Deriving and unboxed types] in TcDeriv
1879 primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty
1880
1881 primLitOps :: String -- The class involved
1882 -> TyCon -- The tycon involved
1883 -> Type -- The type
1884 -> ( LHsExpr RdrName -> LHsExpr RdrName -- Constructs a Q Exp value
1885 , LHsExpr RdrName -> LHsExpr RdrName -- Constructs a boxed value
1886 )
1887 primLitOps str tycon ty = ( assoc_ty_id str tycon litConTbl ty
1888 , \v -> nlHsVar boxRDR `nlHsApp` v
1889 )
1890 where
1891 boxRDR
1892 | ty `eqType` addrPrimTy = unpackCString_RDR
1893 | otherwise = assoc_ty_id str tycon boxConTbl ty
1894
1895 ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
1896 ordOpTbl
1897 = [(charPrimTy , (ltChar_RDR , leChar_RDR , eqChar_RDR , geChar_RDR , gtChar_RDR ))
1898 ,(intPrimTy , (ltInt_RDR , leInt_RDR , eqInt_RDR , geInt_RDR , gtInt_RDR ))
1899 ,(wordPrimTy , (ltWord_RDR , leWord_RDR , eqWord_RDR , geWord_RDR , gtWord_RDR ))
1900 ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR , eqAddr_RDR , geAddr_RDR , gtAddr_RDR ))
1901 ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR , eqFloat_RDR , geFloat_RDR , gtFloat_RDR ))
1902 ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR, eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ]
1903
1904 boxConTbl :: [(Type, RdrName)]
1905 boxConTbl
1906 = [(charPrimTy , getRdrName charDataCon )
1907 ,(intPrimTy , getRdrName intDataCon )
1908 ,(wordPrimTy , getRdrName wordDataCon )
1909 ,(floatPrimTy , getRdrName floatDataCon )
1910 ,(doublePrimTy, getRdrName doubleDataCon)
1911 ]
1912
1913 -- | A table of postfix modifiers for unboxed values.
1914 postfixModTbl :: [(Type, String)]
1915 postfixModTbl
1916 = [(charPrimTy , "#" )
1917 ,(intPrimTy , "#" )
1918 ,(wordPrimTy , "##")
1919 ,(floatPrimTy , "#" )
1920 ,(doublePrimTy, "##")
1921 ]
1922
1923 litConTbl :: [(Type, LHsExpr RdrName -> LHsExpr RdrName)]
1924 litConTbl
1925 = [(charPrimTy , nlHsApp (nlHsVar charPrimL_RDR))
1926 ,(intPrimTy , nlHsApp (nlHsVar intPrimL_RDR)
1927 . nlHsApp (nlHsVar toInteger_RDR))
1928 ,(wordPrimTy , nlHsApp (nlHsVar wordPrimL_RDR)
1929 . nlHsApp (nlHsVar toInteger_RDR))
1930 ,(addrPrimTy , nlHsApp (nlHsVar stringPrimL_RDR)
1931 . nlHsApp (nlHsApp
1932 (nlHsVar map_RDR)
1933 (compose_RDR `nlHsApps`
1934 [ nlHsVar fromIntegral_RDR
1935 , nlHsVar fromEnum_RDR
1936 ])))
1937 ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR)
1938 . nlHsApp (nlHsVar toRational_RDR))
1939 ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR)
1940 . nlHsApp (nlHsVar toRational_RDR))
1941 ]
1942
1943 -- | Lookup `Type` in an association list.
1944 assoc_ty_id :: String -- The class involved
1945 -> TyCon -- The tycon involved
1946 -> [(Type,a)] -- The table
1947 -> Type -- The type
1948 -> a -- The result of the lookup
1949 assoc_ty_id cls_str _ tbl ty
1950 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1951 text "for primitive type" <+> ppr ty)
1952 | otherwise = head res
1953 where
1954 res = [id | (ty',id) <- tbl, ty `eqType` ty']
1955
1956 -----------------------------------------------------------------------
1957
1958 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1959 and_Expr a b = genOpApp a and_RDR b
1960
1961 -----------------------------------------------------------------------
1962
1963 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1964 eq_Expr tycon ty a b
1965 | not (isUnliftedType ty) = genOpApp a eq_RDR b
1966 | otherwise = genPrimOpApp a prim_eq b
1967 where
1968 (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
1969
1970 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1971 untag_Expr _ [] expr = expr
1972 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1973 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1974 [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1975
1976 enum_from_to_Expr
1977 :: LHsExpr RdrName -> LHsExpr RdrName
1978 -> LHsExpr RdrName
1979 enum_from_then_to_Expr
1980 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1981 -> LHsExpr RdrName
1982
1983 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1984 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1985
1986 showParen_Expr
1987 :: LHsExpr RdrName -> LHsExpr RdrName
1988 -> LHsExpr RdrName
1989
1990 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1991
1992 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1993
1994 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
1995 nested_compose_Expr [e] = parenify e
1996 nested_compose_Expr (e:es)
1997 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1998
1999 -- impossible_Expr is used in case RHSs that should never happen.
2000 -- We generate these to keep the desugarer from complaining that they *might* happen!
2001 error_Expr :: String -> LHsExpr RdrName
2002 error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
2003
2004 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
2005 -- method. It is currently only used by Enum.{succ,pred}
2006 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
2007 illegal_Expr meth tp msg =
2008 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
2009
2010 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
2011 -- to include the value of a_RDR in the error string.
2012 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
2013 illegal_toEnum_tag tp maxtag =
2014 nlHsApp (nlHsVar error_RDR)
2015 (nlHsApp (nlHsApp (nlHsVar append_RDR)
2016 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
2017 (nlHsApp (nlHsApp (nlHsApp
2018 (nlHsVar showsPrec_RDR)
2019 (nlHsIntLit 0))
2020 (nlHsVar a_RDR))
2021 (nlHsApp (nlHsApp
2022 (nlHsVar append_RDR)
2023 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
2024 (nlHsApp (nlHsApp (nlHsApp
2025 (nlHsVar showsPrec_RDR)
2026 (nlHsIntLit 0))
2027 (nlHsVar maxtag))
2028 (nlHsLit (mkHsString ")"))))))
2029
2030 parenify :: LHsExpr RdrName -> LHsExpr RdrName
2031 parenify e@(L _ (HsVar _)) = e
2032 parenify e = mkHsPar e
2033
2034 -- genOpApp wraps brackets round the operator application, so that the
2035 -- renamer won't subsequently try to re-associate it.
2036 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2037 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
2038
2039 genPrimOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2040 genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2))
2041
2042 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
2043 :: RdrName
2044 a_RDR = mkVarUnqual (fsLit "a")
2045 b_RDR = mkVarUnqual (fsLit "b")
2046 c_RDR = mkVarUnqual (fsLit "c")
2047 d_RDR = mkVarUnqual (fsLit "d")
2048 f_RDR = mkVarUnqual (fsLit "f")
2049 k_RDR = mkVarUnqual (fsLit "k")
2050 z_RDR = mkVarUnqual (fsLit "z")
2051 ah_RDR = mkVarUnqual (fsLit "a#")
2052 bh_RDR = mkVarUnqual (fsLit "b#")
2053 ch_RDR = mkVarUnqual (fsLit "c#")
2054 dh_RDR = mkVarUnqual (fsLit "d#")
2055
2056 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
2057 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
2058 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
2059 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
2060
2061 a_Expr, b_Expr, c_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr,
2062 true_Expr :: LHsExpr RdrName
2063 a_Expr = nlHsVar a_RDR
2064 b_Expr = nlHsVar b_RDR
2065 c_Expr = nlHsVar c_RDR
2066 ltTag_Expr = nlHsVar ltTag_RDR
2067 eqTag_Expr = nlHsVar eqTag_RDR
2068 gtTag_Expr = nlHsVar gtTag_RDR
2069 false_Expr = nlHsVar false_RDR
2070 true_Expr = nlHsVar true_RDR
2071
2072 a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat RdrName
2073 a_Pat = nlVarPat a_RDR
2074 b_Pat = nlVarPat b_RDR
2075 c_Pat = nlVarPat c_RDR
2076 d_Pat = nlVarPat d_RDR
2077 k_Pat = nlVarPat k_RDR
2078 z_Pat = nlVarPat z_RDR
2079
2080 minusInt_RDR, tagToEnum_RDR :: RdrName
2081 minusInt_RDR = getRdrName (primOpId IntSubOp )
2082 tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)
2083
2084 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
2085 -- Generates Orig s RdrName, for the binding positions
2086 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
2087 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
2088 maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc
2089
2090 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
2091 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
2092
2093 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
2094 -- ^ Make a top-level binder name for an auxiliary binding for a parent name
2095 -- See Note [Auxiliary binders]
2096 mkAuxBinderName parent occ_fun
2097 = mkRdrUnqual (occ_fun stable_parent_occ)
2098 where
2099 stable_parent_occ = mkOccName (occNameSpace parent_occ) stable_string
2100 stable_string
2101 | opt_PprStyle_Debug = parent_stable
2102 | otherwise = parent_stable_hash
2103 parent_stable = nameStableString parent
2104 parent_stable_hash =
2105 let Fingerprint high low = fingerprintString parent_stable
2106 in toBase62 high ++ toBase62Padded low
2107 -- See Note [Base 62 encoding 128-bit integers] in Encoding
2108 parent_occ = nameOccName parent
2109
2110
2111 {-
2112 Note [Auxiliary binders]
2113 ~~~~~~~~~~~~~~~~~~~~~~~~
2114 We often want to make a top-level auxiliary binding. E.g. for comparison we haev
2115
2116 instance Ord T where
2117 compare a b = $con2tag a `compare` $con2tag b
2118
2119 $con2tag :: T -> Int
2120 $con2tag = ...code....
2121
2122 Of course these top-level bindings should all have distinct name, and we are
2123 generating RdrNames here. We can't just use the TyCon or DataCon to distinguish
2124 because with standalone deriving two imported TyCons might both be called T!
2125 (See Trac #7947.)
2126
2127 So we use package name, module name and the name of the parent
2128 (T in this example) as part of the OccName we generate for the new binding.
2129 To make the symbol names short we take a base62 hash of the full name.
2130
2131 In the past we used the *unique* from the parent, but that's not stable across
2132 recompilations as uniques are nondeterministic.
2133 -}