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