Add HsSyn prettyprinter tests
[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 = nlParPat $ nlConVarPat data_con_RDR as_needed
202 con2_pat = nlParPat $ 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 NoSourceText (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 NoSourceText (-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 NoSourceText 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
1205 = nlHsApps showsPrec_RDR [nlHsLit (HsInt NoSourceText p), x]
1206
1207 -- | shows :: Show a => a -> ShowS
1208 mk_shows_app :: LHsExpr RdrName -> LHsExpr RdrName
1209 mk_shows_app x = nlHsApp (nlHsVar shows_RDR) x
1210
1211 getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer
1212 getPrec is_infix get_fixity nm
1213 | not is_infix = appPrecedence
1214 | otherwise = getPrecedence get_fixity nm
1215
1216 appPrecedence :: Integer
1217 appPrecedence = fromIntegral maxPrecedence + 1
1218 -- One more than the precedence of the most
1219 -- tightly-binding operator
1220
1221 getPrecedence :: (Name -> Fixity) -> Name -> Integer
1222 getPrecedence get_fixity nm
1223 = case get_fixity nm of
1224 Fixity _ x _assoc -> fromIntegral x
1225 -- NB: the Report says that associativity is not taken
1226 -- into account for either Read or Show; hence we
1227 -- ignore associativity here
1228
1229 {-
1230 ************************************************************************
1231 * *
1232 Data instances
1233 * *
1234 ************************************************************************
1235
1236 From the data type
1237
1238 data T a b = T1 a b | T2
1239
1240 we generate
1241
1242 $cT1 = mkDataCon $dT "T1" Prefix
1243 $cT2 = mkDataCon $dT "T2" Prefix
1244 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1245 -- the [] is for field labels.
1246
1247 instance (Data a, Data b) => Data (T a b) where
1248 gfoldl k z (T1 a b) = z T `k` a `k` b
1249 gfoldl k z T2 = z T2
1250 -- ToDo: add gmapT,Q,M, gfoldr
1251
1252 gunfold k z c = case conIndex c of
1253 I# 1# -> k (k (z T1))
1254 I# 2# -> z T2
1255
1256 toConstr (T1 _ _) = $cT1
1257 toConstr T2 = $cT2
1258
1259 dataTypeOf _ = $dT
1260
1261 dataCast1 = gcast1 -- If T :: * -> *
1262 dataCast2 = gcast2 -- if T :: * -> * -> *
1263 -}
1264
1265 gen_Data_binds :: SrcSpan
1266 -> TyCon -- For data families, this is the
1267 -- *representation* TyCon
1268 -> TcM (LHsBinds RdrName, -- The method bindings
1269 BagDerivStuff) -- Auxiliary bindings
1270 gen_Data_binds loc rep_tc
1271 = do { dflags <- getDynFlags
1272
1273 -- Make unique names for the data type and constructor
1274 -- auxiliary bindings. Start with the name of the TyCon/DataCon
1275 -- but that might not be unique: see Trac #12245.
1276 ; dt_occ <- chooseUniqueOccTc (mkDataTOcc (getOccName rep_tc))
1277 ; dc_occs <- mapM (chooseUniqueOccTc . mkDataCOcc . getOccName)
1278 (tyConDataCons rep_tc)
1279 ; let dt_rdr = mkRdrUnqual dt_occ
1280 dc_rdrs = map mkRdrUnqual dc_occs
1281
1282 -- OK, now do the work
1283 ; return (gen_data dflags dt_rdr dc_rdrs loc rep_tc) }
1284
1285 gen_data :: DynFlags -> RdrName -> [RdrName]
1286 -> SrcSpan -> TyCon
1287 -> (LHsBinds RdrName, -- The method bindings
1288 BagDerivStuff) -- Auxiliary bindings
1289 gen_data dflags data_type_name constr_names loc rep_tc
1290 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
1291 `unionBags` gcast_binds,
1292 -- Auxiliary definitions: the data type and constructors
1293 listToBag ( genDataTyCon
1294 : zipWith genDataDataCon data_cons constr_names ) )
1295 where
1296 data_cons = tyConDataCons rep_tc
1297 n_cons = length data_cons
1298 one_constr = n_cons == 1
1299 genDataTyCon :: DerivStuff
1300 genDataTyCon -- $dT
1301 = DerivHsBind (mkHsVarBind loc data_type_name rhs,
1302 L loc (TypeSig [L loc data_type_name] sig_ty))
1303
1304 sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR)
1305 rhs = nlHsVar mkDataType_RDR
1306 `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc)))
1307 `nlHsApp` nlList (map nlHsVar constr_names)
1308
1309 genDataDataCon :: DataCon -> RdrName -> DerivStuff
1310 genDataDataCon dc constr_name -- $cT1 etc
1311 = DerivHsBind (mkHsVarBind loc constr_name rhs,
1312 L loc (TypeSig [L loc constr_name] sig_ty))
1313 where
1314 sig_ty = mkLHsSigWcType (nlHsTyVar constr_RDR)
1315 rhs = nlHsApps mkConstr_RDR constr_args
1316
1317 constr_args
1318 = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1319 nlHsVar (data_type_name) -- DataType
1320 , nlHsLit (mkHsString (occNameString dc_occ)) -- String name
1321 , nlList labels -- Field labels
1322 , nlHsVar fixity ] -- Fixity
1323
1324 labels = map (nlHsLit . mkHsString . unpackFS . flLabel)
1325 (dataConFieldLabels dc)
1326 dc_occ = getOccName dc
1327 is_infix = isDataSymOcc dc_occ
1328 fixity | is_infix = infix_RDR
1329 | otherwise = prefix_RDR
1330
1331 ------------ gfoldl
1332 gfoldl_bind = mk_HRFunBind 2 loc gfoldl_RDR (map gfoldl_eqn data_cons)
1333
1334 gfoldl_eqn con
1335 = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1336 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1337 where
1338 con_name :: RdrName
1339 con_name = getRdrName con
1340 as_needed = take (dataConSourceArity con) as_RDRs
1341 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1342
1343 ------------ gunfold
1344 gunfold_bind = mk_HRFunBind 2 loc
1345 gunfold_RDR
1346 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1347 gunfold_rhs)]
1348
1349 gunfold_rhs
1350 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1351 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1352 (map gunfold_alt data_cons)
1353
1354 gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1355 mk_unfold_rhs dc = foldr nlHsApp
1356 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1357 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1358
1359 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1360 -- redundant test, and annoying warning
1361 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1362 | otherwise = nlConPat intDataCon_RDR
1363 [nlLitPat (HsIntPrim NoSourceText (toInteger tag))]
1364 where
1365 tag = dataConTag dc
1366
1367 ------------ toConstr
1368 toCon_bind = mk_FunBind loc toConstr_RDR (zipWith to_con_eqn data_cons constr_names)
1369 to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name)
1370
1371 ------------ dataTypeOf
1372 dataTypeOf_bind = mk_easy_FunBind
1373 loc
1374 dataTypeOf_RDR
1375 [nlWildPat]
1376 (nlHsVar data_type_name)
1377
1378 ------------ gcast1/2
1379 -- Make the binding dataCast1 x = gcast1 x -- if T :: * -> *
1380 -- or dataCast2 x = gcast2 s -- if T :: * -> * -> *
1381 -- (or nothing if T has neither of these two types)
1382
1383 -- But care is needed for data families:
1384 -- If we have data family D a
1385 -- data instance D (a,b,c) = A | B deriving( Data )
1386 -- and we want instance ... => Data (D [(a,b,c)]) where ...
1387 -- then we need dataCast1 x = gcast1 x
1388 -- because D :: * -> *
1389 -- even though rep_tc has kind * -> * -> * -> *
1390 -- Hence looking for the kind of fam_tc not rep_tc
1391 -- See Trac #4896
1392 tycon_kind = case tyConFamInst_maybe rep_tc of
1393 Just (fam_tc, _) -> tyConKind fam_tc
1394 Nothing -> tyConKind rep_tc
1395 gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR
1396 | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
1397 | otherwise = emptyBag
1398 mk_gcast dataCast_RDR gcast_RDR
1399 = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
1400 (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
1401
1402
1403 kind1, kind2 :: Kind
1404 kind1 = liftedTypeKind `mkFunTy` liftedTypeKind
1405 kind2 = liftedTypeKind `mkFunTy` kind1
1406
1407 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
1408 mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
1409 dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,
1410 constr_RDR, dataType_RDR,
1411 eqChar_RDR , ltChar_RDR , geChar_RDR , gtChar_RDR , leChar_RDR ,
1412 eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR ,
1413 eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR ,
1414 eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR ,
1415 eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,
1416 eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR :: RdrName
1417 gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
1418 gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
1419 toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
1420 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1421 dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1")
1422 dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2")
1423 gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1")
1424 gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2")
1425 mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
1426 constr_RDR = tcQual_RDR gENERICS (fsLit "Constr")
1427 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1428 dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType")
1429 conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
1430 prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix")
1431 infix_RDR = dataQual_RDR gENERICS (fsLit "Infix")
1432
1433 eqChar_RDR = varQual_RDR gHC_PRIM (fsLit "eqChar#")
1434 ltChar_RDR = varQual_RDR gHC_PRIM (fsLit "ltChar#")
1435 leChar_RDR = varQual_RDR gHC_PRIM (fsLit "leChar#")
1436 gtChar_RDR = varQual_RDR gHC_PRIM (fsLit "gtChar#")
1437 geChar_RDR = varQual_RDR gHC_PRIM (fsLit "geChar#")
1438
1439 eqInt_RDR = varQual_RDR gHC_PRIM (fsLit "==#")
1440 ltInt_RDR = varQual_RDR gHC_PRIM (fsLit "<#" )
1441 leInt_RDR = varQual_RDR gHC_PRIM (fsLit "<=#")
1442 gtInt_RDR = varQual_RDR gHC_PRIM (fsLit ">#" )
1443 geInt_RDR = varQual_RDR gHC_PRIM (fsLit ">=#")
1444
1445 eqWord_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord#")
1446 ltWord_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord#")
1447 leWord_RDR = varQual_RDR gHC_PRIM (fsLit "leWord#")
1448 gtWord_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord#")
1449 geWord_RDR = varQual_RDR gHC_PRIM (fsLit "geWord#")
1450
1451 eqAddr_RDR = varQual_RDR gHC_PRIM (fsLit "eqAddr#")
1452 ltAddr_RDR = varQual_RDR gHC_PRIM (fsLit "ltAddr#")
1453 leAddr_RDR = varQual_RDR gHC_PRIM (fsLit "leAddr#")
1454 gtAddr_RDR = varQual_RDR gHC_PRIM (fsLit "gtAddr#")
1455 geAddr_RDR = varQual_RDR gHC_PRIM (fsLit "geAddr#")
1456
1457 eqFloat_RDR = varQual_RDR gHC_PRIM (fsLit "eqFloat#")
1458 ltFloat_RDR = varQual_RDR gHC_PRIM (fsLit "ltFloat#")
1459 leFloat_RDR = varQual_RDR gHC_PRIM (fsLit "leFloat#")
1460 gtFloat_RDR = varQual_RDR gHC_PRIM (fsLit "gtFloat#")
1461 geFloat_RDR = varQual_RDR gHC_PRIM (fsLit "geFloat#")
1462
1463 eqDouble_RDR = varQual_RDR gHC_PRIM (fsLit "==##")
1464 ltDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<##" )
1465 leDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<=##")
1466 gtDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">##" )
1467 geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##")
1468
1469 {-
1470 ************************************************************************
1471 * *
1472 Lift instances
1473 * *
1474 ************************************************************************
1475
1476 Example:
1477
1478 data Foo a = Foo a | a :^: a deriving Lift
1479
1480 ==>
1481
1482 instance (Lift a) => Lift (Foo a) where
1483 lift (Foo a)
1484 = appE
1485 (conE
1486 (mkNameG_d "package-name" "ModuleName" "Foo"))
1487 (lift a)
1488 lift (u :^: v)
1489 = infixApp
1490 (lift u)
1491 (conE
1492 (mkNameG_d "package-name" "ModuleName" ":^:"))
1493 (lift v)
1494
1495 Note that (mkNameG_d "package-name" "ModuleName" "Foo") is equivalent to what
1496 'Foo would be when using the -XTemplateHaskell extension. To make sure that
1497 -XDeriveLift can be used on stage-1 compilers, however, we expliticly invoke
1498 makeG_d.
1499 -}
1500
1501 gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1502 gen_Lift_binds loc tycon
1503 | null data_cons = (unitBag (L loc $ mkFunBind (L loc lift_RDR)
1504 [mkMatch (FunRhs (L loc lift_RDR) Prefix)
1505 [nlWildPat] errorMsg_Expr
1506 (noLoc emptyLocalBinds)])
1507 , emptyBag)
1508 | otherwise = (unitBag lift_bind, emptyBag)
1509 where
1510 errorMsg_Expr = nlHsVar error_RDR `nlHsApp` nlHsLit
1511 (mkHsString $ "Can't lift value of empty datatype " ++ tycon_str)
1512
1513 lift_bind = mk_FunBind loc lift_RDR (map pats_etc data_cons)
1514 data_cons = tyConDataCons tycon
1515 tycon_str = occNameString . nameOccName . tyConName $ tycon
1516
1517 pats_etc data_con
1518 = ([con_pat], lift_Expr)
1519 where
1520 con_pat = nlConVarPat data_con_RDR as_needed
1521 data_con_RDR = getRdrName data_con
1522 con_arity = dataConSourceArity data_con
1523 as_needed = take con_arity as_RDRs
1524 lifted_as = zipWithEqual "mk_lift_app" mk_lift_app
1525 tys_needed as_needed
1526 tycon_name = tyConName tycon
1527 is_infix = dataConIsInfix data_con
1528 tys_needed = dataConOrigArgTys data_con
1529
1530 mk_lift_app ty a
1531 | not (isUnliftedType ty) = nlHsApp (nlHsVar lift_RDR)
1532 (nlHsVar a)
1533 | otherwise = nlHsApp (nlHsVar litE_RDR)
1534 (primLitOp (mkBoxExp (nlHsVar a)))
1535 where (primLitOp, mkBoxExp) = primLitOps "Lift" tycon ty
1536
1537 pkg_name = unitIdString . moduleUnitId
1538 . nameModule $ tycon_name
1539 mod_name = moduleNameString . moduleName . nameModule $ tycon_name
1540 con_name = occNameString . nameOccName . dataConName $ data_con
1541
1542 conE_Expr = nlHsApp (nlHsVar conE_RDR)
1543 (nlHsApps mkNameG_dRDR
1544 (map (nlHsLit . mkHsString)
1545 [pkg_name, mod_name, con_name]))
1546
1547 lift_Expr
1548 | is_infix = nlHsApps infixApp_RDR [a1, conE_Expr, a2]
1549 | otherwise = foldl mk_appE_app conE_Expr lifted_as
1550 (a1:a2:_) = lifted_as
1551
1552 mk_appE_app :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1553 mk_appE_app a b = nlHsApps appE_RDR [a, b]
1554
1555 {-
1556 ************************************************************************
1557 * *
1558 Newtype-deriving instances
1559 * *
1560 ************************************************************************
1561
1562 Note [Newtype-deriving instances]
1563 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1564 We take every method in the original instance and `coerce` it to fit
1565 into the derived instance. We need a type annotation on the argument
1566 to `coerce` to make it obvious what instantiation of the method we're
1567 coercing from. So from, say,
1568 class C a b where
1569 op :: a -> [b] -> Int
1570
1571 newtype T x = MkT <rep-ty>
1572
1573 instance C a <rep-ty> => C a (T x) where
1574 op = coerce @ (a -> [<rep-ty>] -> Int)
1575 @ (a -> [T x] -> Int)
1576 op
1577
1578 Notice that we give the 'coerce' two explicitly-visible type arguments
1579 to say how it should be instantiated. Recall
1580
1581 coerce :: Coeercible a b => a -> b
1582
1583 By giving it explicit type arguments we deal with the case where
1584 'op' has a higher rank type, and so we must instantiate 'coerce' with
1585 a polytype. E.g.
1586 class C a where op :: forall b. a -> b -> b
1587 newtype T x = MkT <rep-ty>
1588 instance C <rep-ty> => C (T x) where
1589 op = coerce @ (forall b. <rep-ty> -> b -> b)
1590 @ (forall b. T x -> b -> b)
1591 op
1592
1593 The type checker checks this code, and it currently requires
1594 -XImpredicativeTypes to permit that polymorphic type instantiation,
1595 so we have to switch that flag on locally in TcDeriv.genInst.
1596
1597 See #8503 for more discussion.
1598
1599 Note [Newtype-deriving trickiness]
1600 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1601 Consider (Trac #12768):
1602 class C a where { op :: D a => a -> a }
1603
1604 instance C a => C [a] where { op = opList }
1605
1606 opList :: (C a, D [a]) => [a] -> [a]
1607 opList = ...
1608
1609 Now suppose we try GND on this:
1610 newtype N a = MkN [a] deriving( C )
1611
1612 The GND is expecting to get an implementation of op for N by
1613 coercing opList, thus:
1614
1615 instance C a => C (N a) where { op = opN }
1616
1617 opN :: (C a, D (N a)) => N a -> N a
1618 opN = coerce @(D [a] => [a] -> [a])
1619 @(D (N a) => [N a] -> [N a]
1620 opList
1621
1622 But there is no reason to suppose that (D [a]) and (D (N a))
1623 are inter-coercible; these instances might completely different.
1624 So GHC rightly rejects this code.
1625 -}
1626
1627 gen_Newtype_binds :: SrcSpan
1628 -> Class -- the class being derived
1629 -> [TyVar] -- the tvs in the instance head (this includes
1630 -- the tvs from both the class types and the
1631 -- newtype itself)
1632 -> [Type] -- instance head parameters (incl. newtype)
1633 -> Type -- the representation type
1634 -> TcM (LHsBinds RdrName, BagDerivStuff)
1635 -- See Note [Newtype-deriving instances]
1636 gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
1637 = do let ats = classATs cls
1638 atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats )
1639 mapM mk_atf_inst ats
1640 return ( listToBag $ map mk_bind (classMethods cls)
1641 , listToBag $ map DerivFamInst atf_insts )
1642 where
1643 coerce_RDR = getRdrName coerceId
1644
1645 mk_bind :: Id -> LHsBind RdrName
1646 mk_bind meth_id
1647 = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch
1648 (FunRhs (L loc meth_RDR) Prefix)
1649 [] rhs_expr]
1650 where
1651 Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id
1652
1653 meth_RDR = getRdrName meth_id
1654
1655 rhs_expr = nlHsVar coerce_RDR `nlHsAppType` from_ty
1656 `nlHsAppType` to_ty
1657 `nlHsApp` nlHsVar meth_RDR
1658
1659 mk_atf_inst :: TyCon -> TcM FamInst
1660 mk_atf_inst fam_tc = do
1661 rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc))
1662 rep_lhs_tys
1663 let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' rep_cvs'
1664 fam_tc rep_lhs_tys rep_rhs_ty
1665 -- Check (c) from Note [GND and associated type families] in TcDeriv
1666 checkValidTyFamEqn (Just (cls, cls_tvs, lhs_env)) fam_tc rep_tvs'
1667 rep_cvs' rep_lhs_tys rep_rhs_ty loc
1668 newFamInst SynFamilyInst axiom
1669 where
1670 cls_tvs = classTyVars cls
1671 in_scope = mkInScopeSet $ mkVarSet inst_tvs
1672 lhs_env = zipTyEnv cls_tvs inst_tys
1673 lhs_subst = mkTvSubst in_scope lhs_env
1674 rhs_env = zipTyEnv cls_tvs $ changeLast inst_tys rhs_ty
1675 rhs_subst = mkTvSubst in_scope rhs_env
1676 fam_tvs = tyConTyVars fam_tc
1677 rep_lhs_tys = substTyVars lhs_subst fam_tvs
1678 rep_rhs_tys = substTyVars rhs_subst fam_tvs
1679 rep_rhs_ty = mkTyConApp fam_tc rep_rhs_tys
1680 rep_tcvs = tyCoVarsOfTypesList rep_lhs_tys
1681 (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs
1682 rep_tvs' = toposortTyVars rep_tvs
1683 rep_cvs' = toposortTyVars rep_cvs
1684
1685 nlHsAppType :: LHsExpr RdrName -> Type -> LHsExpr RdrName
1686 nlHsAppType e s = noLoc (e `HsAppType` hs_ty)
1687 where
1688 hs_ty = mkHsWildCardBndrs $ nlHsParTy (typeToLHsType s)
1689
1690 nlExprWithTySig :: LHsExpr RdrName -> Type -> LHsExpr RdrName
1691 nlExprWithTySig e s = noLoc (e `ExprWithTySig` hs_ty)
1692 where
1693 hs_ty = mkLHsSigWcType (typeToLHsType s)
1694
1695 mkCoerceClassMethEqn :: Class -- the class being derived
1696 -> [TyVar] -- the tvs in the instance head (this includes
1697 -- the tvs from both the class types and the
1698 -- newtype itself)
1699 -> [Type] -- instance head parameters (incl. newtype)
1700 -> Type -- the representation type
1701 -> Id -- the method to look at
1702 -> Pair Type
1703 -- See Note [Newtype-deriving instances]
1704 -- See also Note [Newtype-deriving trickiness]
1705 -- The pair is the (from_type, to_type), where to_type is
1706 -- the type of the method we are tyrying to get
1707 mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty id
1708 = Pair (substTy rhs_subst user_meth_ty)
1709 (substTy lhs_subst user_meth_ty)
1710 where
1711 cls_tvs = classTyVars cls
1712 in_scope = mkInScopeSet $ mkVarSet inst_tvs
1713 lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs inst_tys)
1714 rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast inst_tys rhs_ty))
1715 (_class_tvs, _class_constraint, user_meth_ty)
1716 = tcSplitMethodTy (varType id)
1717
1718 {-
1719 ************************************************************************
1720 * *
1721 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1722 * *
1723 ************************************************************************
1724
1725 \begin{verbatim}
1726 data Foo ... = ...
1727
1728 con2tag_Foo :: Foo ... -> Int#
1729 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1730 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1731 \end{verbatim}
1732
1733 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1734 fiddling around.
1735 -}
1736
1737 genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName)
1738 genAuxBindSpec loc (DerivCon2Tag tycon)
1739 = (mk_FunBind loc rdr_name eqns,
1740 L loc (TypeSig [L loc rdr_name] sig_ty))
1741 where
1742 rdr_name = con2tag_RDR tycon
1743
1744 sig_ty = mkLHsSigWcType $ L loc $ HsCoreTy $
1745 mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
1746 mkParentType tycon `mkFunTy` intPrimTy
1747
1748 lots_of_constructors = tyConFamilySize tycon > 8
1749 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1750 -- but we don't do vectored returns any more.
1751
1752 eqns | lots_of_constructors = [get_tag_eqn]
1753 | otherwise = map mk_eqn (tyConDataCons tycon)
1754
1755 get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
1756
1757 mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1758 mk_eqn con = ([nlWildConPat con],
1759 nlHsLit (HsIntPrim NoSourceText
1760 (toInteger ((dataConTag con) - fIRST_TAG))))
1761
1762 genAuxBindSpec loc (DerivTag2Con tycon)
1763 = (mk_FunBind loc rdr_name
1764 [([nlConVarPat intDataCon_RDR [a_RDR]],
1765 nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
1766 L loc (TypeSig [L loc rdr_name] sig_ty))
1767 where
1768 sig_ty = mkLHsSigWcType $ L loc $
1769 HsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
1770 intTy `mkFunTy` mkParentType tycon
1771
1772 rdr_name = tag2con_RDR tycon
1773
1774 genAuxBindSpec loc (DerivMaxTag tycon)
1775 = (mkHsVarBind loc rdr_name rhs,
1776 L loc (TypeSig [L loc rdr_name] sig_ty))
1777 where
1778 rdr_name = maxtag_RDR tycon
1779 sig_ty = mkLHsSigWcType (L loc (HsCoreTy intTy))
1780 rhs = nlHsApp (nlHsVar intDataCon_RDR)
1781 (nlHsLit (HsIntPrim NoSourceText max_tag))
1782 max_tag = case (tyConDataCons tycon) of
1783 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1784
1785 type SeparateBagsDerivStuff =
1786 -- AuxBinds and SYB bindings
1787 ( Bag (LHsBind RdrName, LSig RdrName)
1788 -- Extra family instances (used by Generic and DeriveAnyClass)
1789 , Bag (FamInst) )
1790
1791 genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
1792 genAuxBinds loc b = genAuxBinds' b2 where
1793 (b1,b2) = partitionBagWith splitDerivAuxBind b
1794 splitDerivAuxBind (DerivAuxBind x) = Left x
1795 splitDerivAuxBind x = Right x
1796
1797 rm_dups = foldrBag dup_check emptyBag
1798 dup_check a b = if anyBag (== a) b then b else consBag a b
1799
1800 genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
1801 genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec loc) (rm_dups b1)
1802 , emptyBag )
1803 f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
1804 f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
1805 f (DerivHsBind b) = add1 b
1806 f (DerivFamInst t) = add2 t
1807
1808 add1 x (a,b) = (x `consBag` a,b)
1809 add2 x (a,b) = (a,x `consBag` b)
1810
1811 mkParentType :: TyCon -> Type
1812 -- Turn the representation tycon of a family into
1813 -- a use of its family constructor
1814 mkParentType tc
1815 = case tyConFamInst_maybe tc of
1816 Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
1817 Just (fam_tc,tys) -> mkTyConApp fam_tc tys
1818
1819 {-
1820 ************************************************************************
1821 * *
1822 \subsection{Utility bits for generating bindings}
1823 * *
1824 ************************************************************************
1825 -}
1826
1827 mk_FunBind :: SrcSpan -> RdrName
1828 -> [([LPat RdrName], LHsExpr RdrName)]
1829 -> LHsBind RdrName
1830 mk_FunBind = mk_HRFunBind 0 -- by using mk_FunBind and not mk_HRFunBind,
1831 -- the caller says that the Void case needs no
1832 -- patterns
1833
1834 -- | This variant of 'mk_FunBind' puts an 'Arity' number of wildcards before
1835 -- the "=" in the empty-data-decl case. This is necessary if the function
1836 -- has a higher-rank type, like foldl. (See deriving/should_compile/T4302)
1837 mk_HRFunBind :: Arity -> SrcSpan -> RdrName
1838 -> [([LPat RdrName], LHsExpr RdrName)]
1839 -> LHsBind RdrName
1840 mk_HRFunBind arity loc fun pats_and_exprs
1841 = mkHRRdrFunBind arity (L loc fun) matches
1842 where
1843 matches = [mkMatch (FunRhs (L loc fun) Prefix) p e
1844 (noLoc emptyLocalBinds)
1845 | (p,e) <-pats_and_exprs]
1846
1847 mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
1848 mkRdrFunBind = mkHRRdrFunBind 0
1849
1850 mkHRRdrFunBind :: Arity -> Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
1851 mkHRRdrFunBind arity fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
1852 where
1853 -- Catch-all eqn looks like
1854 -- fmap = error "Void fmap"
1855 -- It's needed if there no data cons at all,
1856 -- which can happen with -XEmptyDataDecls
1857 -- See Trac #4302
1858 matches' = if null matches
1859 then [mkMatch (FunRhs fun Prefix)
1860 (replicate arity nlWildPat)
1861 (error_Expr str) (noLoc emptyLocalBinds)]
1862 else matches
1863 str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
1864
1865 box :: String -- The class involved
1866 -> TyCon -- The tycon involved
1867 -> LHsExpr RdrName -- The argument
1868 -> Type -- The argument type
1869 -> LHsExpr RdrName -- Boxed version of the arg
1870 -- See Note [Deriving and unboxed types] in TcDeriv
1871 box cls_str tycon arg arg_ty = nlHsApp (nlHsVar box_con) arg
1872 where
1873 box_con = assoc_ty_id cls_str tycon boxConTbl arg_ty
1874
1875 ---------------------
1876 primOrdOps :: String -- The class involved
1877 -> TyCon -- The tycon involved
1878 -> Type -- The type
1879 -> (RdrName, RdrName, RdrName, RdrName, RdrName) -- (lt,le,eq,ge,gt)
1880 -- See Note [Deriving and unboxed types] in TcDeriv
1881 primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty
1882
1883 primLitOps :: String -- The class involved
1884 -> TyCon -- The tycon involved
1885 -> Type -- The type
1886 -> ( LHsExpr RdrName -> LHsExpr RdrName -- Constructs a Q Exp value
1887 , LHsExpr RdrName -> LHsExpr RdrName -- Constructs a boxed value
1888 )
1889 primLitOps str tycon ty = ( assoc_ty_id str tycon litConTbl ty
1890 , \v -> nlHsVar boxRDR `nlHsApp` v
1891 )
1892 where
1893 boxRDR
1894 | ty `eqType` addrPrimTy = unpackCString_RDR
1895 | otherwise = assoc_ty_id str tycon boxConTbl ty
1896
1897 ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
1898 ordOpTbl
1899 = [(charPrimTy , (ltChar_RDR , leChar_RDR , eqChar_RDR , geChar_RDR , gtChar_RDR ))
1900 ,(intPrimTy , (ltInt_RDR , leInt_RDR , eqInt_RDR , geInt_RDR , gtInt_RDR ))
1901 ,(wordPrimTy , (ltWord_RDR , leWord_RDR , eqWord_RDR , geWord_RDR , gtWord_RDR ))
1902 ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR , eqAddr_RDR , geAddr_RDR , gtAddr_RDR ))
1903 ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR , eqFloat_RDR , geFloat_RDR , gtFloat_RDR ))
1904 ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR, eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ]
1905
1906 boxConTbl :: [(Type, RdrName)]
1907 boxConTbl
1908 = [(charPrimTy , getRdrName charDataCon )
1909 ,(intPrimTy , getRdrName intDataCon )
1910 ,(wordPrimTy , getRdrName wordDataCon )
1911 ,(floatPrimTy , getRdrName floatDataCon )
1912 ,(doublePrimTy, getRdrName doubleDataCon)
1913 ]
1914
1915 -- | A table of postfix modifiers for unboxed values.
1916 postfixModTbl :: [(Type, String)]
1917 postfixModTbl
1918 = [(charPrimTy , "#" )
1919 ,(intPrimTy , "#" )
1920 ,(wordPrimTy , "##")
1921 ,(floatPrimTy , "#" )
1922 ,(doublePrimTy, "##")
1923 ]
1924
1925 litConTbl :: [(Type, LHsExpr RdrName -> LHsExpr RdrName)]
1926 litConTbl
1927 = [(charPrimTy , nlHsApp (nlHsVar charPrimL_RDR))
1928 ,(intPrimTy , nlHsApp (nlHsVar intPrimL_RDR)
1929 . nlHsApp (nlHsVar toInteger_RDR))
1930 ,(wordPrimTy , nlHsApp (nlHsVar wordPrimL_RDR)
1931 . nlHsApp (nlHsVar toInteger_RDR))
1932 ,(addrPrimTy , nlHsApp (nlHsVar stringPrimL_RDR)
1933 . nlHsApp (nlHsApp
1934 (nlHsVar map_RDR)
1935 (compose_RDR `nlHsApps`
1936 [ nlHsVar fromIntegral_RDR
1937 , nlHsVar fromEnum_RDR
1938 ])))
1939 ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR)
1940 . nlHsApp (nlHsVar toRational_RDR))
1941 ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR)
1942 . nlHsApp (nlHsVar toRational_RDR))
1943 ]
1944
1945 -- | Lookup `Type` in an association list.
1946 assoc_ty_id :: String -- The class involved
1947 -> TyCon -- The tycon involved
1948 -> [(Type,a)] -- The table
1949 -> Type -- The type
1950 -> a -- The result of the lookup
1951 assoc_ty_id cls_str _ tbl ty
1952 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1953 text "for primitive type" <+> ppr ty)
1954 | otherwise = head res
1955 where
1956 res = [id | (ty',id) <- tbl, ty `eqType` ty']
1957
1958 -----------------------------------------------------------------------
1959
1960 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1961 and_Expr a b = genOpApp a and_RDR b
1962
1963 -----------------------------------------------------------------------
1964
1965 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1966 eq_Expr tycon ty a b
1967 | not (isUnliftedType ty) = genOpApp a eq_RDR b
1968 | otherwise = genPrimOpApp a prim_eq b
1969 where
1970 (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
1971
1972 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1973 untag_Expr _ [] expr = expr
1974 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1975 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1976 [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1977
1978 enum_from_to_Expr
1979 :: LHsExpr RdrName -> LHsExpr RdrName
1980 -> LHsExpr RdrName
1981 enum_from_then_to_Expr
1982 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1983 -> LHsExpr RdrName
1984
1985 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1986 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1987
1988 showParen_Expr
1989 :: LHsExpr RdrName -> LHsExpr RdrName
1990 -> LHsExpr RdrName
1991
1992 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1993
1994 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1995
1996 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
1997 nested_compose_Expr [e] = parenify e
1998 nested_compose_Expr (e:es)
1999 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
2000
2001 -- impossible_Expr is used in case RHSs that should never happen.
2002 -- We generate these to keep the desugarer from complaining that they *might* happen!
2003 error_Expr :: String -> LHsExpr RdrName
2004 error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
2005
2006 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
2007 -- method. It is currently only used by Enum.{succ,pred}
2008 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
2009 illegal_Expr meth tp msg =
2010 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
2011
2012 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
2013 -- to include the value of a_RDR in the error string.
2014 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
2015 illegal_toEnum_tag tp maxtag =
2016 nlHsApp (nlHsVar error_RDR)
2017 (nlHsApp (nlHsApp (nlHsVar append_RDR)
2018 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
2019 (nlHsApp (nlHsApp (nlHsApp
2020 (nlHsVar showsPrec_RDR)
2021 (nlHsIntLit 0))
2022 (nlHsVar a_RDR))
2023 (nlHsApp (nlHsApp
2024 (nlHsVar append_RDR)
2025 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
2026 (nlHsApp (nlHsApp (nlHsApp
2027 (nlHsVar showsPrec_RDR)
2028 (nlHsIntLit 0))
2029 (nlHsVar maxtag))
2030 (nlHsLit (mkHsString ")"))))))
2031
2032 parenify :: LHsExpr RdrName -> LHsExpr RdrName
2033 parenify e@(L _ (HsVar _)) = e
2034 parenify e = mkHsPar e
2035
2036 -- genOpApp wraps brackets round the operator application, so that the
2037 -- renamer won't subsequently try to re-associate it.
2038 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2039 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
2040
2041 genPrimOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2042 genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2))
2043
2044 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
2045 :: RdrName
2046 a_RDR = mkVarUnqual (fsLit "a")
2047 b_RDR = mkVarUnqual (fsLit "b")
2048 c_RDR = mkVarUnqual (fsLit "c")
2049 d_RDR = mkVarUnqual (fsLit "d")
2050 f_RDR = mkVarUnqual (fsLit "f")
2051 k_RDR = mkVarUnqual (fsLit "k")
2052 z_RDR = mkVarUnqual (fsLit "z")
2053 ah_RDR = mkVarUnqual (fsLit "a#")
2054 bh_RDR = mkVarUnqual (fsLit "b#")
2055 ch_RDR = mkVarUnqual (fsLit "c#")
2056 dh_RDR = mkVarUnqual (fsLit "d#")
2057
2058 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
2059 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
2060 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
2061 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
2062
2063 a_Expr, b_Expr, c_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr,
2064 true_Expr :: LHsExpr RdrName
2065 a_Expr = nlHsVar a_RDR
2066 b_Expr = nlHsVar b_RDR
2067 c_Expr = nlHsVar c_RDR
2068 ltTag_Expr = nlHsVar ltTag_RDR
2069 eqTag_Expr = nlHsVar eqTag_RDR
2070 gtTag_Expr = nlHsVar gtTag_RDR
2071 false_Expr = nlHsVar false_RDR
2072 true_Expr = nlHsVar true_RDR
2073
2074 a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat RdrName
2075 a_Pat = nlVarPat a_RDR
2076 b_Pat = nlVarPat b_RDR
2077 c_Pat = nlVarPat c_RDR
2078 d_Pat = nlVarPat d_RDR
2079 k_Pat = nlVarPat k_RDR
2080 z_Pat = nlVarPat z_RDR
2081
2082 minusInt_RDR, tagToEnum_RDR :: RdrName
2083 minusInt_RDR = getRdrName (primOpId IntSubOp )
2084 tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)
2085
2086 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
2087 -- Generates Orig s RdrName, for the binding positions
2088 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
2089 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
2090 maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc
2091
2092 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
2093 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
2094
2095 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
2096 -- ^ Make a top-level binder name for an auxiliary binding for a parent name
2097 -- See Note [Auxiliary binders]
2098 mkAuxBinderName parent occ_fun
2099 = mkRdrUnqual (occ_fun stable_parent_occ)
2100 where
2101 stable_parent_occ = mkOccName (occNameSpace parent_occ) stable_string
2102 stable_string
2103 | opt_PprStyle_Debug = parent_stable
2104 | otherwise = parent_stable_hash
2105 parent_stable = nameStableString parent
2106 parent_stable_hash =
2107 let Fingerprint high low = fingerprintString parent_stable
2108 in toBase62 high ++ toBase62Padded low
2109 -- See Note [Base 62 encoding 128-bit integers] in Encoding
2110 parent_occ = nameOccName parent
2111
2112
2113 {-
2114 Note [Auxiliary binders]
2115 ~~~~~~~~~~~~~~~~~~~~~~~~
2116 We often want to make a top-level auxiliary binding. E.g. for comparison we haev
2117
2118 instance Ord T where
2119 compare a b = $con2tag a `compare` $con2tag b
2120
2121 $con2tag :: T -> Int
2122 $con2tag = ...code....
2123
2124 Of course these top-level bindings should all have distinct name, and we are
2125 generating RdrNames here. We can't just use the TyCon or DataCon to distinguish
2126 because with standalone deriving two imported TyCons might both be called T!
2127 (See Trac #7947.)
2128
2129 So we use package name, module name and the name of the parent
2130 (T in this example) as part of the OccName we generate for the new binding.
2131 To make the symbol names short we take a base62 hash of the full name.
2132
2133 In the past we used the *unique* from the parent, but that's not stable across
2134 recompilations as uniques are nondeterministic.
2135 -}