d8fb62044b5ff558893c2017e2385cc9d5cff95d
[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
611 [ nlHsVarApps intDataCon_RDR [ah_RDR]
612 , nlHsLit (HsInt (mkIntegralLit (-1 :: Int)))]))
613
614 to_enum dflags
615 = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
616 nlHsIf (nlHsApps and_RDR
617 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
618 nlHsApps le_RDR [ nlHsVar a_RDR
619 , nlHsVar (maxtag_RDR dflags tycon)]])
620 (nlHsVarApps (tag2con_RDR dflags tycon) [a_RDR])
621 (illegal_toEnum_tag occ_nm (maxtag_RDR dflags tycon))
622
623 enum_from dflags
624 = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
625 untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
626 nlHsApps map_RDR
627 [nlHsVar (tag2con_RDR dflags tycon),
628 nlHsPar (enum_from_to_Expr
629 (nlHsVarApps intDataCon_RDR [ah_RDR])
630 (nlHsVar (maxtag_RDR dflags tycon)))]
631
632 enum_from_then dflags
633 = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
634 untag_Expr dflags tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
635 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $
636 nlHsPar (enum_from_then_to_Expr
637 (nlHsVarApps intDataCon_RDR [ah_RDR])
638 (nlHsVarApps intDataCon_RDR [bh_RDR])
639 (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
640 nlHsVarApps intDataCon_RDR [bh_RDR]])
641 (nlHsIntLit 0)
642 (nlHsVar (maxtag_RDR dflags tycon))
643 ))
644
645 from_enum dflags
646 = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
647 untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
648 (nlHsVarApps intDataCon_RDR [ah_RDR])
649
650 {-
651 ************************************************************************
652 * *
653 Bounded instances
654 * *
655 ************************************************************************
656 -}
657
658 gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
659 gen_Bounded_binds loc tycon
660 | isEnumerationTyCon tycon
661 = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
662 | otherwise
663 = ASSERT(isSingleton data_cons)
664 (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)
665 where
666 data_cons = tyConDataCons tycon
667
668 ----- enum-flavored: ---------------------------
669 min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
670 max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
671
672 data_con_1 = head data_cons
673 data_con_N = last data_cons
674 data_con_1_RDR = getRdrName data_con_1
675 data_con_N_RDR = getRdrName data_con_N
676
677 ----- single-constructor-flavored: -------------
678 arity = dataConSourceArity data_con_1
679
680 min_bound_1con = mkHsVarBind loc minBound_RDR $
681 nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
682 max_bound_1con = mkHsVarBind loc maxBound_RDR $
683 nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
684
685 {-
686 ************************************************************************
687 * *
688 Ix instances
689 * *
690 ************************************************************************
691
692 Deriving @Ix@ is only possible for enumeration types and
693 single-constructor types. We deal with them in turn.
694
695 For an enumeration type, e.g.,
696 \begin{verbatim}
697 data Foo ... = N1 | N2 | ... | Nn
698 \end{verbatim}
699 things go not too differently from @Enum@:
700 \begin{verbatim}
701 instance ... Ix (Foo ...) where
702 range (a, b)
703 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
704
705 -- or, really...
706 range (a, b)
707 = case (con2tag_Foo a) of { a# ->
708 case (con2tag_Foo b) of { b# ->
709 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
710 }}
711
712 -- Generate code for unsafeIndex, because using index leads
713 -- to lots of redundant range tests
714 unsafeIndex c@(a, b) d
715 = case (con2tag_Foo d -# con2tag_Foo a) of
716 r# -> I# r#
717
718 inRange (a, b) c
719 = let
720 p_tag = con2tag_Foo c
721 in
722 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
723
724 -- or, really...
725 inRange (a, b) c
726 = case (con2tag_Foo a) of { a_tag ->
727 case (con2tag_Foo b) of { b_tag ->
728 case (con2tag_Foo c) of { c_tag ->
729 if (c_tag >=# a_tag) then
730 c_tag <=# b_tag
731 else
732 False
733 }}}
734 \end{verbatim}
735 (modulo suitable case-ification to handle the unlifted tags)
736
737 For a single-constructor type (NB: this includes all tuples), e.g.,
738 \begin{verbatim}
739 data Foo ... = MkFoo a b Int Double c c
740 \end{verbatim}
741 we follow the scheme given in Figure~19 of the Haskell~1.2 report
742 (p.~147).
743 -}
744
745 gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff)
746
747 gen_Ix_binds loc tycon = do
748 dflags <- getDynFlags
749 return $ if isEnumerationTyCon tycon
750 then (enum_ixes dflags, listToBag $ map DerivAuxBind
751 [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
752 else (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))
753 where
754 --------------------------------------------------------------
755 enum_ixes dflags = listToBag
756 [ enum_range dflags
757 , enum_index dflags
758 , enum_inRange dflags
759 ]
760
761 enum_range dflags
762 = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
763 untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
764 untag_Expr dflags tycon [(b_RDR, bh_RDR)] $
765 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $
766 nlHsPar (enum_from_to_Expr
767 (nlHsVarApps intDataCon_RDR [ah_RDR])
768 (nlHsVarApps intDataCon_RDR [bh_RDR]))
769
770 enum_index dflags
771 = mk_easy_FunBind loc unsafeIndex_RDR
772 [noLoc (AsPat (noLoc c_RDR)
773 (nlTuplePat [a_Pat, nlWildPat] Boxed)),
774 d_Pat] (
775 untag_Expr dflags tycon [(a_RDR, ah_RDR)] (
776 untag_Expr dflags tycon [(d_RDR, dh_RDR)] (
777 let
778 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
779 in
780 nlHsCase
781 (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
782 [mkHsCaseAlt (nlVarPat c_RDR) rhs]
783 ))
784 )
785
786 -- This produces something like `(ch >= ah) && (ch <= bh)`
787 enum_inRange dflags
788 = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
789 untag_Expr dflags tycon [(a_RDR, ah_RDR)] (
790 untag_Expr dflags tycon [(b_RDR, bh_RDR)] (
791 untag_Expr dflags tycon [(c_RDR, ch_RDR)] (
792 -- This used to use `if`, which interacts badly with RebindableSyntax.
793 -- See #11396.
794 nlHsApps and_RDR
795 [ genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)
796 , genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR)
797 ]
798 )))
799
800 --------------------------------------------------------------
801 single_con_ixes
802 = listToBag [single_con_range, single_con_index, single_con_inRange]
803
804 data_con
805 = case tyConSingleDataCon_maybe tycon of -- just checking...
806 Nothing -> panic "get_Ix_binds"
807 Just dc -> dc
808
809 con_arity = dataConSourceArity data_con
810 data_con_RDR = getRdrName data_con
811
812 as_needed = take con_arity as_RDRs
813 bs_needed = take con_arity bs_RDRs
814 cs_needed = take con_arity cs_RDRs
815
816 con_pat xs = nlConVarPat data_con_RDR xs
817 con_expr = nlHsVarApps data_con_RDR cs_needed
818
819 --------------------------------------------------------------
820 single_con_range
821 = mk_easy_FunBind loc range_RDR
822 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
823 noLoc (mkHsComp ListComp stmts con_expr)
824 where
825 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
826
827 mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
828 (nlHsApp (nlHsVar range_RDR)
829 (mkLHsVarTuple [a,b]))
830
831 ----------------
832 single_con_index
833 = mk_easy_FunBind loc unsafeIndex_RDR
834 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
835 con_pat cs_needed]
836 -- We need to reverse the order we consider the components in
837 -- so that
838 -- range (l,u) !! index (l,u) i == i -- when i is in range
839 -- (from http://haskell.org/onlinereport/ix.html) holds.
840 (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
841 where
842 -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
843 mk_index [] = nlHsIntLit 0
844 mk_index [(l,u,i)] = mk_one l u i
845 mk_index ((l,u,i) : rest)
846 = genOpApp (
847 mk_one l u i
848 ) plus_RDR (
849 genOpApp (
850 (nlHsApp (nlHsVar unsafeRangeSize_RDR)
851 (mkLHsVarTuple [l,u]))
852 ) times_RDR (mk_index rest)
853 )
854 mk_one l u i
855 = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i]
856
857 ------------------
858 single_con_inRange
859 = mk_easy_FunBind loc inRange_RDR
860 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
861 con_pat cs_needed] $
862 if con_arity == 0
863 -- If the product type has no fields, inRange is trivially true
864 -- (see Trac #12853).
865 then true_Expr
866 else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range
867 as_needed bs_needed cs_needed)
868 where
869 in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
870
871 {-
872 ************************************************************************
873 * *
874 Read instances
875 * *
876 ************************************************************************
877
878 Example
879
880 infix 4 %%
881 data T = Int %% Int
882 | T1 { f1 :: Int }
883 | T2 T
884
885 instance Read T where
886 readPrec =
887 parens
888 ( prec 4 (
889 do x <- ReadP.step Read.readPrec
890 expectP (Symbol "%%")
891 y <- ReadP.step Read.readPrec
892 return (x %% y))
893 +++
894 prec (appPrec+1) (
895 -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
896 -- Record construction binds even more tightly than application
897 do expectP (Ident "T1")
898 expectP (Punc '{')
899 expectP (Ident "f1")
900 expectP (Punc '=')
901 x <- ReadP.reset Read.readPrec
902 expectP (Punc '}')
903 return (T1 { f1 = x }))
904 +++
905 prec appPrec (
906 do expectP (Ident "T2")
907 x <- ReadP.step Read.readPrec
908 return (T2 x))
909 )
910
911 readListPrec = readListPrecDefault
912 readList = readListDefault
913
914
915 Note [Use expectP]
916 ~~~~~~~~~~~~~~~~~~
917 Note that we use
918 expectP (Ident "T1")
919 rather than
920 Ident "T1" <- lexP
921 The latter desugares to inline code for matching the Ident and the
922 string, and this can be very voluminous. The former is much more
923 compact. Cf Trac #7258, although that also concerned non-linearity in
924 the occurrence analyser, a separate issue.
925
926 Note [Read for empty data types]
927 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
928 What should we get for this? (Trac #7931)
929 data Emp deriving( Read ) -- No data constructors
930
931 Here we want
932 read "[]" :: [Emp] to succeed, returning []
933 So we do NOT want
934 instance Read Emp where
935 readPrec = error "urk"
936 Rather we want
937 instance Read Emp where
938 readPred = pfail -- Same as choose []
939
940 Because 'pfail' allows the parser to backtrack, but 'error' doesn't.
941 These instances are also useful for Read (Either Int Emp), where
942 we want to be able to parse (Left 3) just fine.
943 -}
944
945 gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
946
947 gen_Read_binds get_fixity loc tycon
948 = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
949 where
950 -----------------------------------------------------------------------
951 default_readlist
952 = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
953
954 default_readlistprec
955 = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
956 -----------------------------------------------------------------------
957
958 data_cons = tyConDataCons tycon
959 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
960
961 read_prec = mkHsVarBind loc readPrec_RDR
962 (nlHsApp (nlHsVar parens_RDR) read_cons)
963
964 read_cons | null data_cons = nlHsVar pfail_RDR -- See Note [Read for empty data types]
965 | otherwise = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
966 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
967
968 read_nullary_cons
969 = case nullary_cons of
970 [] -> []
971 [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])]
972 _ -> [nlHsApp (nlHsVar choose_RDR)
973 (nlList (map mk_pair nullary_cons))]
974 -- NB For operators the parens around (:=:) are matched by the
975 -- enclosing "parens" call, so here we must match the naked
976 -- data_con_str con
977
978 match_con con | isSym con_str = [symbol_pat con_str]
979 | otherwise = ident_h_pat con_str
980 where
981 con_str = data_con_str con
982 -- For nullary constructors we must match Ident s for normal constrs
983 -- and Symbol s for operators
984
985 mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),
986 result_expr con []]
987
988 read_non_nullary_con data_con
989 | is_infix = mk_parser infix_prec infix_stmts body
990 | is_record = mk_parser record_prec record_stmts body
991 -- Using these two lines instead allows the derived
992 -- read for infix and record bindings to read the prefix form
993 -- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body)
994 -- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
995 | otherwise = prefix_parser
996 where
997 body = result_expr data_con as_needed
998 con_str = data_con_str data_con
999
1000 prefix_parser = mk_parser prefix_prec prefix_stmts body
1001
1002 read_prefix_con
1003 | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"]
1004 | otherwise = ident_h_pat con_str
1005
1006 read_infix_con
1007 | isSym con_str = [symbol_pat con_str]
1008 | otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"]
1009
1010 prefix_stmts -- T a b c
1011 = read_prefix_con ++ read_args
1012
1013 infix_stmts -- a %% b, or a `T` b
1014 = [read_a1]
1015 ++ read_infix_con
1016 ++ [read_a2]
1017
1018 record_stmts -- T { f1 = a, f2 = b }
1019 = read_prefix_con
1020 ++ [read_punc "{"]
1021 ++ concat (intersperse [read_punc ","] field_stmts)
1022 ++ [read_punc "}"]
1023
1024 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
1025
1026 con_arity = dataConSourceArity data_con
1027 labels = map flLabel $ dataConFieldLabels data_con
1028 dc_nm = getName data_con
1029 is_infix = dataConIsInfix data_con
1030 is_record = length labels > 0
1031 as_needed = take con_arity as_RDRs
1032 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
1033 (read_a1:read_a2:_) = read_args
1034
1035 prefix_prec = appPrecedence
1036 infix_prec = getPrecedence get_fixity dc_nm
1037 record_prec = appPrecedence + 1 -- Record construction binds even more tightly
1038 -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
1039
1040 ------------------------------------------------------------------------
1041 -- Helpers
1042 ------------------------------------------------------------------------
1043 mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
1044 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b })
1045 , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])]
1046 con_app con as = nlHsVarApps (getRdrName con) as -- con as
1047 result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
1048
1049 -- For constructors and field labels ending in '#', we hackily
1050 -- let the lexer generate two tokens, and look for both in sequence
1051 -- Thus [Ident "I"; Symbol "#"]. See Trac #5041
1052 ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ]
1053 | otherwise = [ ident_pat s ]
1054
1055 bindLex pat = noLoc (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat)) -- expectP p
1056 -- See Note [Use expectP]
1057 ident_pat s = bindLex $ nlHsApps ident_RDR [nlHsLit (mkHsString s)] -- expectP (Ident "foo")
1058 symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)] -- expectP (Symbol ">>")
1059 read_punc c = bindLex $ nlHsApps punc_RDR [nlHsLit (mkHsString c)] -- expectP (Punc "<")
1060
1061 data_con_str con = occNameString (getOccName con)
1062
1063 read_arg a ty = ASSERT( not (isUnliftedType ty) )
1064 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
1065
1066 read_field lbl a = read_lbl lbl ++
1067 [read_punc "=",
1068 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
1069
1070 -- When reading field labels we might encounter
1071 -- a = 3
1072 -- _a = 3
1073 -- or (#) = 4
1074 -- Note the parens!
1075 read_lbl lbl | isSym lbl_str
1076 = [read_punc "(", symbol_pat lbl_str, read_punc ")"]
1077 | otherwise
1078 = ident_h_pat lbl_str
1079 where
1080 lbl_str = unpackFS lbl
1081
1082 {-
1083 ************************************************************************
1084 * *
1085 Show instances
1086 * *
1087 ************************************************************************
1088
1089 Example
1090
1091 infixr 5 :^:
1092
1093 data Tree a = Leaf a | Tree a :^: Tree a
1094
1095 instance (Show a) => Show (Tree a) where
1096
1097 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
1098 where
1099 showStr = showString "Leaf " . showsPrec (app_prec+1) m
1100
1101 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
1102 where
1103 showStr = showsPrec (up_prec+1) u .
1104 showString " :^: " .
1105 showsPrec (up_prec+1) v
1106 -- Note: right-associativity of :^: ignored
1107
1108 up_prec = 5 -- Precedence of :^:
1109 app_prec = 10 -- Application has precedence one more than
1110 -- the most tightly-binding operator
1111 -}
1112
1113 gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1114
1115 gen_Show_binds get_fixity loc tycon
1116 = (unitBag shows_prec, emptyBag)
1117 where
1118 data_cons = tyConDataCons tycon
1119 shows_prec = mkFunBindSE 1 loc showsPrec_RDR (map pats_etc data_cons)
1120 comma_space = nlHsVar showCommaSpace_RDR
1121
1122 pats_etc data_con
1123 | nullary_con = -- skip the showParen junk...
1124 ASSERT(null bs_needed)
1125 ([nlWildPat, con_pat], mk_showString_app op_con_str)
1126 | otherwise =
1127 ([a_Pat, con_pat],
1128 showParen_Expr (genOpApp a_Expr ge_RDR
1129 (nlHsLit (HsInt (mkIntegralLit con_prec_plus_one))))
1130 (nlHsPar (nested_compose_Expr show_thingies)))
1131 where
1132 data_con_RDR = getRdrName data_con
1133 con_arity = dataConSourceArity data_con
1134 bs_needed = take con_arity bs_RDRs
1135 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
1136 con_pat = nlConVarPat data_con_RDR bs_needed
1137 nullary_con = con_arity == 0
1138 labels = map flLabel $ dataConFieldLabels data_con
1139 lab_fields = length labels
1140 record_syntax = lab_fields > 0
1141
1142 dc_nm = getName data_con
1143 dc_occ_nm = getOccName data_con
1144 con_str = occNameString dc_occ_nm
1145 op_con_str = wrapOpParens con_str
1146 backquote_str = wrapOpBackquotes con_str
1147
1148 show_thingies
1149 | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
1150 | record_syntax = mk_showString_app (op_con_str ++ " {") :
1151 show_record_args ++ [mk_showString_app "}"]
1152 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
1153
1154 show_label l = mk_showString_app (nm ++ " = ")
1155 -- Note the spaces around the "=" sign. If we
1156 -- don't have them then we get Foo { x=-1 } and
1157 -- the "=-" parses as a single lexeme. Only the
1158 -- space after the '=' is necessary, but it
1159 -- seems tidier to have them both sides.
1160 where
1161 nm = wrapOpParens (unpackFS l)
1162
1163 show_args = zipWith show_arg bs_needed arg_tys
1164 (show_arg1:show_arg2:_) = show_args
1165 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
1166
1167 -- Assumption for record syntax: no of fields == no of
1168 -- labelled fields (and in same order)
1169 show_record_args = concat $
1170 intersperse [comma_space] $
1171 [ [show_label lbl, arg]
1172 | (lbl,arg) <- zipEqual "gen_Show_binds"
1173 labels show_args ]
1174
1175 show_arg :: RdrName -> Type -> LHsExpr RdrName
1176 show_arg b arg_ty
1177 | isUnliftedType arg_ty
1178 -- See Note [Deriving and unboxed types] in TcDeriv
1179 = nlHsApps compose_RDR [mk_shows_app boxed_arg,
1180 mk_showString_app postfixMod]
1181 | otherwise
1182 = mk_showsPrec_app arg_prec arg
1183 where
1184 arg = nlHsVar b
1185 boxed_arg = box "Show" tycon arg arg_ty
1186 postfixMod = assoc_ty_id "Show" tycon postfixModTbl arg_ty
1187
1188 -- Fixity stuff
1189 is_infix = dataConIsInfix data_con
1190 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1191 arg_prec | record_syntax = 0 -- Record fields don't need parens
1192 | otherwise = con_prec_plus_one
1193
1194 wrapOpParens :: String -> String
1195 wrapOpParens s | isSym s = '(' : s ++ ")"
1196 | otherwise = s
1197
1198 wrapOpBackquotes :: String -> String
1199 wrapOpBackquotes s | isSym s = s
1200 | otherwise = '`' : s ++ "`"
1201
1202 isSym :: String -> Bool
1203 isSym "" = False
1204 isSym (c : _) = startsVarSym c || startsConSym c
1205
1206 -- | showString :: String -> ShowS
1207 mk_showString_app :: String -> LHsExpr RdrName
1208 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1209
1210 -- | showsPrec :: Show a => Int -> a -> ShowS
1211 mk_showsPrec_app :: Integer -> LHsExpr RdrName -> LHsExpr RdrName
1212 mk_showsPrec_app p x
1213 = nlHsApps showsPrec_RDR [nlHsLit (HsInt (mkIntegralLit p)), x]
1214
1215 -- | shows :: Show a => a -> ShowS
1216 mk_shows_app :: LHsExpr RdrName -> LHsExpr RdrName
1217 mk_shows_app x = nlHsApp (nlHsVar shows_RDR) x
1218
1219 getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer
1220 getPrec is_infix get_fixity nm
1221 | not is_infix = appPrecedence
1222 | otherwise = getPrecedence get_fixity nm
1223
1224 appPrecedence :: Integer
1225 appPrecedence = fromIntegral maxPrecedence + 1
1226 -- One more than the precedence of the most
1227 -- tightly-binding operator
1228
1229 getPrecedence :: (Name -> Fixity) -> Name -> Integer
1230 getPrecedence get_fixity nm
1231 = case get_fixity nm of
1232 Fixity _ x _assoc -> fromIntegral x
1233 -- NB: the Report says that associativity is not taken
1234 -- into account for either Read or Show; hence we
1235 -- ignore associativity here
1236
1237 {-
1238 ************************************************************************
1239 * *
1240 Data instances
1241 * *
1242 ************************************************************************
1243
1244 From the data type
1245
1246 data T a b = T1 a b | T2
1247
1248 we generate
1249
1250 $cT1 = mkDataCon $dT "T1" Prefix
1251 $cT2 = mkDataCon $dT "T2" Prefix
1252 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1253 -- the [] is for field labels.
1254
1255 instance (Data a, Data b) => Data (T a b) where
1256 gfoldl k z (T1 a b) = z T `k` a `k` b
1257 gfoldl k z T2 = z T2
1258 -- ToDo: add gmapT,Q,M, gfoldr
1259
1260 gunfold k z c = case conIndex c of
1261 I# 1# -> k (k (z T1))
1262 I# 2# -> z T2
1263
1264 toConstr (T1 _ _) = $cT1
1265 toConstr T2 = $cT2
1266
1267 dataTypeOf _ = $dT
1268
1269 dataCast1 = gcast1 -- If T :: * -> *
1270 dataCast2 = gcast2 -- if T :: * -> * -> *
1271 -}
1272
1273 gen_Data_binds :: SrcSpan
1274 -> TyCon -- For data families, this is the
1275 -- *representation* TyCon
1276 -> TcM (LHsBinds RdrName, -- The method bindings
1277 BagDerivStuff) -- Auxiliary bindings
1278 gen_Data_binds loc rep_tc
1279 = do { dflags <- getDynFlags
1280
1281 -- Make unique names for the data type and constructor
1282 -- auxiliary bindings. Start with the name of the TyCon/DataCon
1283 -- but that might not be unique: see Trac #12245.
1284 ; dt_occ <- chooseUniqueOccTc (mkDataTOcc (getOccName rep_tc))
1285 ; dc_occs <- mapM (chooseUniqueOccTc . mkDataCOcc . getOccName)
1286 (tyConDataCons rep_tc)
1287 ; let dt_rdr = mkRdrUnqual dt_occ
1288 dc_rdrs = map mkRdrUnqual dc_occs
1289
1290 -- OK, now do the work
1291 ; return (gen_data dflags dt_rdr dc_rdrs loc rep_tc) }
1292
1293 gen_data :: DynFlags -> RdrName -> [RdrName]
1294 -> SrcSpan -> TyCon
1295 -> (LHsBinds RdrName, -- The method bindings
1296 BagDerivStuff) -- Auxiliary bindings
1297 gen_data dflags data_type_name constr_names loc rep_tc
1298 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
1299 `unionBags` gcast_binds,
1300 -- Auxiliary definitions: the data type and constructors
1301 listToBag ( genDataTyCon
1302 : zipWith genDataDataCon data_cons constr_names ) )
1303 where
1304 data_cons = tyConDataCons rep_tc
1305 n_cons = length data_cons
1306 one_constr = n_cons == 1
1307 genDataTyCon :: DerivStuff
1308 genDataTyCon -- $dT
1309 = DerivHsBind (mkHsVarBind loc data_type_name rhs,
1310 L loc (TypeSig [L loc data_type_name] sig_ty))
1311
1312 sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR)
1313 rhs = nlHsVar mkDataType_RDR
1314 `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc)))
1315 `nlHsApp` nlList (map nlHsVar constr_names)
1316
1317 genDataDataCon :: DataCon -> RdrName -> DerivStuff
1318 genDataDataCon dc constr_name -- $cT1 etc
1319 = DerivHsBind (mkHsVarBind loc constr_name rhs,
1320 L loc (TypeSig [L loc constr_name] sig_ty))
1321 where
1322 sig_ty = mkLHsSigWcType (nlHsTyVar constr_RDR)
1323 rhs = nlHsApps mkConstr_RDR constr_args
1324
1325 constr_args
1326 = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1327 nlHsVar (data_type_name) -- DataType
1328 , nlHsLit (mkHsString (occNameString dc_occ)) -- String name
1329 , nlList labels -- Field labels
1330 , nlHsVar fixity ] -- Fixity
1331
1332 labels = map (nlHsLit . mkHsString . unpackFS . flLabel)
1333 (dataConFieldLabels dc)
1334 dc_occ = getOccName dc
1335 is_infix = isDataSymOcc dc_occ
1336 fixity | is_infix = infix_RDR
1337 | otherwise = prefix_RDR
1338
1339 ------------ gfoldl
1340 gfoldl_bind = mkFunBindSE 3 loc gfoldl_RDR (map gfoldl_eqn data_cons)
1341
1342 gfoldl_eqn con
1343 = ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed],
1344 foldl mk_k_app (z_Expr `nlHsApp` nlHsVar con_name) as_needed)
1345 where
1346 con_name :: RdrName
1347 con_name = getRdrName con
1348 as_needed = take (dataConSourceArity con) as_RDRs
1349 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1350
1351 ------------ gunfold
1352 gunfold_bind = mk_easy_FunBind loc
1353 gunfold_RDR
1354 [k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat]
1355 gunfold_rhs
1356
1357 gunfold_rhs
1358 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1359 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1360 (map gunfold_alt data_cons)
1361
1362 gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1363 mk_unfold_rhs dc = foldr nlHsApp
1364 (z_Expr `nlHsApp` nlHsVar (getRdrName dc))
1365 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1366
1367 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1368 -- redundant test, and annoying warning
1369 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1370 | otherwise = nlConPat intDataCon_RDR
1371 [nlLitPat (HsIntPrim NoSourceText (toInteger tag))]
1372 where
1373 tag = dataConTag dc
1374
1375 ------------ toConstr
1376 toCon_bind = mkFunBindSE 1 loc toConstr_RDR
1377 (zipWith to_con_eqn data_cons constr_names)
1378 to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name)
1379
1380 ------------ dataTypeOf
1381 dataTypeOf_bind = mk_easy_FunBind
1382 loc
1383 dataTypeOf_RDR
1384 [nlWildPat]
1385 (nlHsVar data_type_name)
1386
1387 ------------ gcast1/2
1388 -- Make the binding dataCast1 x = gcast1 x -- if T :: * -> *
1389 -- or dataCast2 x = gcast2 s -- if T :: * -> * -> *
1390 -- (or nothing if T has neither of these two types)
1391
1392 -- But care is needed for data families:
1393 -- If we have data family D a
1394 -- data instance D (a,b,c) = A | B deriving( Data )
1395 -- and we want instance ... => Data (D [(a,b,c)]) where ...
1396 -- then we need dataCast1 x = gcast1 x
1397 -- because D :: * -> *
1398 -- even though rep_tc has kind * -> * -> * -> *
1399 -- Hence looking for the kind of fam_tc not rep_tc
1400 -- See Trac #4896
1401 tycon_kind = case tyConFamInst_maybe rep_tc of
1402 Just (fam_tc, _) -> tyConKind fam_tc
1403 Nothing -> tyConKind rep_tc
1404 gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR
1405 | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
1406 | otherwise = emptyBag
1407 mk_gcast dataCast_RDR gcast_RDR
1408 = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
1409 (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
1410
1411
1412 kind1, kind2 :: Kind
1413 kind1 = liftedTypeKind `mkFunTy` liftedTypeKind
1414 kind2 = liftedTypeKind `mkFunTy` kind1
1415
1416 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
1417 mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
1418 dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,
1419 constr_RDR, dataType_RDR,
1420 eqChar_RDR , ltChar_RDR , geChar_RDR , gtChar_RDR , leChar_RDR ,
1421 eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR ,
1422 eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR ,
1423 eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR ,
1424 eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,
1425 eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR :: RdrName
1426 gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
1427 gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
1428 toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
1429 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1430 dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1")
1431 dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2")
1432 gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1")
1433 gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2")
1434 mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
1435 constr_RDR = tcQual_RDR gENERICS (fsLit "Constr")
1436 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1437 dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType")
1438 conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
1439 prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix")
1440 infix_RDR = dataQual_RDR gENERICS (fsLit "Infix")
1441
1442 eqChar_RDR = varQual_RDR gHC_PRIM (fsLit "eqChar#")
1443 ltChar_RDR = varQual_RDR gHC_PRIM (fsLit "ltChar#")
1444 leChar_RDR = varQual_RDR gHC_PRIM (fsLit "leChar#")
1445 gtChar_RDR = varQual_RDR gHC_PRIM (fsLit "gtChar#")
1446 geChar_RDR = varQual_RDR gHC_PRIM (fsLit "geChar#")
1447
1448 eqInt_RDR = varQual_RDR gHC_PRIM (fsLit "==#")
1449 ltInt_RDR = varQual_RDR gHC_PRIM (fsLit "<#" )
1450 leInt_RDR = varQual_RDR gHC_PRIM (fsLit "<=#")
1451 gtInt_RDR = varQual_RDR gHC_PRIM (fsLit ">#" )
1452 geInt_RDR = varQual_RDR gHC_PRIM (fsLit ">=#")
1453
1454 eqWord_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord#")
1455 ltWord_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord#")
1456 leWord_RDR = varQual_RDR gHC_PRIM (fsLit "leWord#")
1457 gtWord_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord#")
1458 geWord_RDR = varQual_RDR gHC_PRIM (fsLit "geWord#")
1459
1460 eqAddr_RDR = varQual_RDR gHC_PRIM (fsLit "eqAddr#")
1461 ltAddr_RDR = varQual_RDR gHC_PRIM (fsLit "ltAddr#")
1462 leAddr_RDR = varQual_RDR gHC_PRIM (fsLit "leAddr#")
1463 gtAddr_RDR = varQual_RDR gHC_PRIM (fsLit "gtAddr#")
1464 geAddr_RDR = varQual_RDR gHC_PRIM (fsLit "geAddr#")
1465
1466 eqFloat_RDR = varQual_RDR gHC_PRIM (fsLit "eqFloat#")
1467 ltFloat_RDR = varQual_RDR gHC_PRIM (fsLit "ltFloat#")
1468 leFloat_RDR = varQual_RDR gHC_PRIM (fsLit "leFloat#")
1469 gtFloat_RDR = varQual_RDR gHC_PRIM (fsLit "gtFloat#")
1470 geFloat_RDR = varQual_RDR gHC_PRIM (fsLit "geFloat#")
1471
1472 eqDouble_RDR = varQual_RDR gHC_PRIM (fsLit "==##")
1473 ltDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<##" )
1474 leDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<=##")
1475 gtDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">##" )
1476 geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##")
1477
1478 {-
1479 ************************************************************************
1480 * *
1481 Lift instances
1482 * *
1483 ************************************************************************
1484
1485 Example:
1486
1487 data Foo a = Foo a | a :^: a deriving Lift
1488
1489 ==>
1490
1491 instance (Lift a) => Lift (Foo a) where
1492 lift (Foo a)
1493 = appE
1494 (conE
1495 (mkNameG_d "package-name" "ModuleName" "Foo"))
1496 (lift a)
1497 lift (u :^: v)
1498 = infixApp
1499 (lift u)
1500 (conE
1501 (mkNameG_d "package-name" "ModuleName" ":^:"))
1502 (lift v)
1503
1504 Note that (mkNameG_d "package-name" "ModuleName" "Foo") is equivalent to what
1505 'Foo would be when using the -XTemplateHaskell extension. To make sure that
1506 -XDeriveLift can be used on stage-1 compilers, however, we explicitly invoke
1507 makeG_d.
1508 -}
1509
1510 gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1511 gen_Lift_binds loc tycon
1512 | null data_cons = (unitBag (L loc $ mkFunBind (L loc lift_RDR)
1513 [mkMatch (mkPrefixFunRhs (L loc lift_RDR))
1514 [nlWildPat] errorMsg_Expr
1515 (noLoc emptyLocalBinds)])
1516 , emptyBag)
1517 | otherwise = (unitBag lift_bind, emptyBag)
1518 where
1519 -- We may want to make mkFunBindSE's error message generation general
1520 -- enough to avoid needing to duplicate its logic here. On the other
1521 -- hand, it may not be worth the trouble.
1522 errorMsg_Expr = nlHsVar error_RDR `nlHsApp` nlHsLit
1523 (mkHsString $ "Can't lift value of empty datatype " ++ tycon_str)
1524
1525 lift_bind = mkFunBindSE 1 loc lift_RDR (map pats_etc data_cons)
1526 data_cons = tyConDataCons tycon
1527 tycon_str = occNameString . nameOccName . tyConName $ tycon
1528
1529 pats_etc data_con
1530 = ([con_pat], lift_Expr)
1531 where
1532 con_pat = nlConVarPat data_con_RDR as_needed
1533 data_con_RDR = getRdrName data_con
1534 con_arity = dataConSourceArity data_con
1535 as_needed = take con_arity as_RDRs
1536 lifted_as = zipWithEqual "mk_lift_app" mk_lift_app
1537 tys_needed as_needed
1538 tycon_name = tyConName tycon
1539 is_infix = dataConIsInfix data_con
1540 tys_needed = dataConOrigArgTys data_con
1541
1542 mk_lift_app ty a
1543 | not (isUnliftedType ty) = nlHsApp (nlHsVar lift_RDR)
1544 (nlHsVar a)
1545 | otherwise = nlHsApp (nlHsVar litE_RDR)
1546 (primLitOp (mkBoxExp (nlHsVar a)))
1547 where (primLitOp, mkBoxExp) = primLitOps "Lift" tycon ty
1548
1549 pkg_name = unitIdString . moduleUnitId
1550 . nameModule $ tycon_name
1551 mod_name = moduleNameString . moduleName . nameModule $ tycon_name
1552 con_name = occNameString . nameOccName . dataConName $ data_con
1553
1554 conE_Expr = nlHsApp (nlHsVar conE_RDR)
1555 (nlHsApps mkNameG_dRDR
1556 (map (nlHsLit . mkHsString)
1557 [pkg_name, mod_name, con_name]))
1558
1559 lift_Expr
1560 | is_infix = nlHsApps infixApp_RDR [a1, conE_Expr, a2]
1561 | otherwise = foldl mk_appE_app conE_Expr lifted_as
1562 (a1:a2:_) = lifted_as
1563
1564 mk_appE_app :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1565 mk_appE_app a b = nlHsApps appE_RDR [a, b]
1566
1567 {-
1568 ************************************************************************
1569 * *
1570 Newtype-deriving instances
1571 * *
1572 ************************************************************************
1573
1574 Note [Newtype-deriving instances]
1575 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1576 We take every method in the original instance and `coerce` it to fit
1577 into the derived instance. We need a type annotation on the argument
1578 to `coerce` to make it obvious what instantiation of the method we're
1579 coercing from. So from, say,
1580 class C a b where
1581 op :: a -> [b] -> Int
1582
1583 newtype T x = MkT <rep-ty>
1584
1585 instance C a <rep-ty> => C a (T x) where
1586 op = coerce @ (a -> [<rep-ty>] -> Int)
1587 @ (a -> [T x] -> Int)
1588 op
1589
1590 Notice that we give the 'coerce' two explicitly-visible type arguments
1591 to say how it should be instantiated. Recall
1592
1593 coerce :: Coeercible a b => a -> b
1594
1595 By giving it explicit type arguments we deal with the case where
1596 'op' has a higher rank type, and so we must instantiate 'coerce' with
1597 a polytype. E.g.
1598 class C a where op :: forall b. a -> b -> b
1599 newtype T x = MkT <rep-ty>
1600 instance C <rep-ty> => C (T x) where
1601 op = coerce @ (forall b. <rep-ty> -> b -> b)
1602 @ (forall b. T x -> b -> b)
1603 op
1604
1605 The type checker checks this code, and it currently requires
1606 -XImpredicativeTypes to permit that polymorphic type instantiation,
1607 so we have to switch that flag on locally in TcDeriv.genInst.
1608
1609 See #8503 for more discussion.
1610
1611 Note [Newtype-deriving trickiness]
1612 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1613 Consider (Trac #12768):
1614 class C a where { op :: D a => a -> a }
1615
1616 instance C a => C [a] where { op = opList }
1617
1618 opList :: (C a, D [a]) => [a] -> [a]
1619 opList = ...
1620
1621 Now suppose we try GND on this:
1622 newtype N a = MkN [a] deriving( C )
1623
1624 The GND is expecting to get an implementation of op for N by
1625 coercing opList, thus:
1626
1627 instance C a => C (N a) where { op = opN }
1628
1629 opN :: (C a, D (N a)) => N a -> N a
1630 opN = coerce @(D [a] => [a] -> [a])
1631 @(D (N a) => [N a] -> [N a]
1632 opList
1633
1634 But there is no reason to suppose that (D [a]) and (D (N a))
1635 are inter-coercible; these instances might completely different.
1636 So GHC rightly rejects this code.
1637 -}
1638
1639 gen_Newtype_binds :: SrcSpan
1640 -> Class -- the class being derived
1641 -> [TyVar] -- the tvs in the instance head (this includes
1642 -- the tvs from both the class types and the
1643 -- newtype itself)
1644 -> [Type] -- instance head parameters (incl. newtype)
1645 -> Type -- the representation type
1646 -> TcM (LHsBinds RdrName, BagDerivStuff)
1647 -- See Note [Newtype-deriving instances]
1648 gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
1649 = do let ats = classATs cls
1650 atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats )
1651 mapM mk_atf_inst ats
1652 return ( listToBag $ map mk_bind (classMethods cls)
1653 , listToBag $ map DerivFamInst atf_insts )
1654 where
1655 mk_bind :: Id -> LHsBind RdrName
1656 mk_bind meth_id
1657 = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch
1658 (mkPrefixFunRhs (L loc meth_RDR))
1659 [] rhs_expr]
1660 where
1661 Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id
1662
1663 meth_RDR = getRdrName meth_id
1664
1665 rhs_expr = nlHsVar (getRdrName coerceId)
1666 `nlHsAppType` from_ty
1667 `nlHsAppType` to_ty
1668 `nlHsApp` nlHsVar meth_RDR
1669
1670 mk_atf_inst :: TyCon -> TcM FamInst
1671 mk_atf_inst fam_tc = do
1672 rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc))
1673 rep_lhs_tys
1674 let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' rep_cvs'
1675 fam_tc rep_lhs_tys rep_rhs_ty
1676 -- Check (c) from Note [GND and associated type families] in TcDeriv
1677 checkValidTyFamEqn (Just (cls, cls_tvs, lhs_env)) fam_tc rep_tvs'
1678 rep_cvs' rep_lhs_tys rep_rhs_ty loc
1679 newFamInst SynFamilyInst axiom
1680 where
1681 cls_tvs = classTyVars cls
1682 in_scope = mkInScopeSet $ mkVarSet inst_tvs
1683 lhs_env = zipTyEnv cls_tvs inst_tys
1684 lhs_subst = mkTvSubst in_scope lhs_env
1685 rhs_env = zipTyEnv cls_tvs $ changeLast inst_tys rhs_ty
1686 rhs_subst = mkTvSubst in_scope rhs_env
1687 fam_tvs = tyConTyVars fam_tc
1688 rep_lhs_tys = substTyVars lhs_subst fam_tvs
1689 rep_rhs_tys = substTyVars rhs_subst fam_tvs
1690 rep_rhs_ty = mkTyConApp fam_tc rep_rhs_tys
1691 rep_tcvs = tyCoVarsOfTypesList rep_lhs_tys
1692 (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs
1693 rep_tvs' = toposortTyVars rep_tvs
1694 rep_cvs' = toposortTyVars rep_cvs
1695
1696 nlHsAppType :: LHsExpr RdrName -> Type -> LHsExpr RdrName
1697 nlHsAppType e s = noLoc (e `HsAppType` hs_ty)
1698 where
1699 hs_ty = mkHsWildCardBndrs $ nlHsParTy (typeToLHsType s)
1700
1701 nlExprWithTySig :: LHsExpr RdrName -> Type -> LHsExpr RdrName
1702 nlExprWithTySig e s = noLoc (e `ExprWithTySig` hs_ty)
1703 where
1704 hs_ty = mkLHsSigWcType (typeToLHsType s)
1705
1706 mkCoerceClassMethEqn :: Class -- the class being derived
1707 -> [TyVar] -- the tvs in the instance head (this includes
1708 -- the tvs from both the class types and the
1709 -- newtype itself)
1710 -> [Type] -- instance head parameters (incl. newtype)
1711 -> Type -- the representation type
1712 -> Id -- the method to look at
1713 -> Pair Type
1714 -- See Note [Newtype-deriving instances]
1715 -- See also Note [Newtype-deriving trickiness]
1716 -- The pair is the (from_type, to_type), where to_type is
1717 -- the type of the method we are tyrying to get
1718 mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty id
1719 = Pair (substTy rhs_subst user_meth_ty)
1720 (substTy lhs_subst user_meth_ty)
1721 where
1722 cls_tvs = classTyVars cls
1723 in_scope = mkInScopeSet $ mkVarSet inst_tvs
1724 lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs inst_tys)
1725 rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast inst_tys rhs_ty))
1726 (_class_tvs, _class_constraint, user_meth_ty)
1727 = tcSplitMethodTy (varType id)
1728
1729 {-
1730 ************************************************************************
1731 * *
1732 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1733 * *
1734 ************************************************************************
1735
1736 \begin{verbatim}
1737 data Foo ... = ...
1738
1739 con2tag_Foo :: Foo ... -> Int#
1740 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1741 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1742 \end{verbatim}
1743
1744 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1745 fiddling around.
1746 -}
1747
1748 genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec
1749 -> (LHsBind RdrName, LSig RdrName)
1750 genAuxBindSpec dflags loc (DerivCon2Tag tycon)
1751 = (mkFunBindSE 0 loc rdr_name eqns,
1752 L loc (TypeSig [L loc rdr_name] sig_ty))
1753 where
1754 rdr_name = con2tag_RDR dflags tycon
1755
1756 sig_ty = mkLHsSigWcType $ L loc $ HsCoreTy $
1757 mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
1758 mkParentType tycon `mkFunTy` intPrimTy
1759
1760 lots_of_constructors = tyConFamilySize tycon > 8
1761 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1762 -- but we don't do vectored returns any more.
1763
1764 eqns | lots_of_constructors = [get_tag_eqn]
1765 | otherwise = map mk_eqn (tyConDataCons tycon)
1766
1767 get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
1768
1769 mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1770 mk_eqn con = ([nlWildConPat con],
1771 nlHsLit (HsIntPrim NoSourceText
1772 (toInteger ((dataConTag con) - fIRST_TAG))))
1773
1774 genAuxBindSpec dflags loc (DerivTag2Con tycon)
1775 = (mkFunBindSE 0 loc rdr_name
1776 [([nlConVarPat intDataCon_RDR [a_RDR]],
1777 nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
1778 L loc (TypeSig [L loc rdr_name] sig_ty))
1779 where
1780 sig_ty = mkLHsSigWcType $ L loc $
1781 HsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
1782 intTy `mkFunTy` mkParentType tycon
1783
1784 rdr_name = tag2con_RDR dflags tycon
1785
1786 genAuxBindSpec dflags loc (DerivMaxTag tycon)
1787 = (mkHsVarBind loc rdr_name rhs,
1788 L loc (TypeSig [L loc rdr_name] sig_ty))
1789 where
1790 rdr_name = maxtag_RDR dflags tycon
1791 sig_ty = mkLHsSigWcType (L loc (HsCoreTy intTy))
1792 rhs = nlHsApp (nlHsVar intDataCon_RDR)
1793 (nlHsLit (HsIntPrim NoSourceText max_tag))
1794 max_tag = case (tyConDataCons tycon) of
1795 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1796
1797 type SeparateBagsDerivStuff =
1798 -- AuxBinds and SYB bindings
1799 ( Bag (LHsBind RdrName, LSig RdrName)
1800 -- Extra family instances (used by Generic and DeriveAnyClass)
1801 , Bag (FamInst) )
1802
1803 genAuxBinds :: DynFlags -> SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
1804 genAuxBinds dflags loc b = genAuxBinds' b2 where
1805 (b1,b2) = partitionBagWith splitDerivAuxBind b
1806 splitDerivAuxBind (DerivAuxBind x) = Left x
1807 splitDerivAuxBind x = Right x
1808
1809 rm_dups = foldrBag dup_check emptyBag
1810 dup_check a b = if anyBag (== a) b then b else consBag a b
1811
1812 genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
1813 genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec dflags loc) (rm_dups b1)
1814 , emptyBag )
1815 f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
1816 f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
1817 f (DerivHsBind b) = add1 b
1818 f (DerivFamInst t) = add2 t
1819
1820 add1 x (a,b) = (x `consBag` a,b)
1821 add2 x (a,b) = (a,x `consBag` b)
1822
1823 mkParentType :: TyCon -> Type
1824 -- Turn the representation tycon of a family into
1825 -- a use of its family constructor
1826 mkParentType tc
1827 = case tyConFamInst_maybe tc of
1828 Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
1829 Just (fam_tc,tys) -> mkTyConApp fam_tc tys
1830
1831 {-
1832 ************************************************************************
1833 * *
1834 \subsection{Utility bits for generating bindings}
1835 * *
1836 ************************************************************************
1837 -}
1838
1839 -- | Make a function binding. If no equations are given, produce a function
1840 -- with the given arity that produces a stock error.
1841 mkFunBindSE :: Arity -> SrcSpan -> RdrName
1842 -> [([LPat RdrName], LHsExpr RdrName)]
1843 -> LHsBind RdrName
1844 mkFunBindSE arity loc fun pats_and_exprs
1845 = mkRdrFunBindSE arity (L loc fun) matches
1846 where
1847 matches = [mkMatch (mkPrefixFunRhs (L loc fun)) p e
1848 (noLoc emptyLocalBinds)
1849 | (p,e) <-pats_and_exprs]
1850
1851 mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
1852 mkRdrFunBind fun@(L loc _fun_rdr) matches
1853 = L loc (mkFunBind fun matches)
1854
1855 -- | Produces a function binding. When no equations are given, it generates
1856 -- a binding of the given arity and an empty case expression
1857 -- for the last argument that it passes to the given function to produce
1858 -- the right-hand side.
1859 mkRdrFunBindEC :: Arity
1860 -> (LHsExpr RdrName -> LHsExpr RdrName)
1861 -> Located RdrName
1862 -> [LMatch RdrName (LHsExpr RdrName)]
1863 -> LHsBind RdrName
1864 mkRdrFunBindEC arity catch_all
1865 fun@(L loc _fun_rdr) matches = L loc (mkFunBind fun matches')
1866 where
1867 -- Catch-all eqn looks like
1868 -- fmap _ z = case z of {}
1869 -- or
1870 -- traverse _ z = pure (case z of)
1871 -- or
1872 -- foldMap _ z = mempty
1873 -- It's needed if there no data cons at all,
1874 -- which can happen with -XEmptyDataDecls
1875 -- See Trac #4302
1876 matches' = if null matches
1877 then [mkMatch (mkPrefixFunRhs fun)
1878 (replicate (arity - 1) nlWildPat ++ [z_Pat])
1879 (catch_all $ nlHsCase z_Expr [])
1880 (noLoc emptyLocalBinds)]
1881 else matches
1882
1883 -- | Produces a function binding. When there are no equations, it generates
1884 -- a binding with the given arity that produces an error based on the name of
1885 -- the type of the last argument.
1886 mkRdrFunBindSE :: Arity -> Located RdrName ->
1887 [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
1888 mkRdrFunBindSE arity
1889 fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
1890 where
1891 -- Catch-all eqn looks like
1892 -- compare _ _ = error "Void compare"
1893 -- It's needed if there no data cons at all,
1894 -- which can happen with -XEmptyDataDecls
1895 -- See Trac #4302
1896 matches' = if null matches
1897 then [mkMatch (mkPrefixFunRhs fun)
1898 (replicate arity nlWildPat)
1899 (error_Expr str) (noLoc emptyLocalBinds)]
1900 else matches
1901 str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
1902
1903
1904 box :: String -- The class involved
1905 -> TyCon -- The tycon involved
1906 -> LHsExpr RdrName -- The argument
1907 -> Type -- The argument type
1908 -> LHsExpr RdrName -- Boxed version of the arg
1909 -- See Note [Deriving and unboxed types] in TcDeriv
1910 box cls_str tycon arg arg_ty = nlHsApp (nlHsVar box_con) arg
1911 where
1912 box_con = assoc_ty_id cls_str tycon boxConTbl arg_ty
1913
1914 ---------------------
1915 primOrdOps :: String -- The class involved
1916 -> TyCon -- The tycon involved
1917 -> Type -- The type
1918 -> (RdrName, RdrName, RdrName, RdrName, RdrName) -- (lt,le,eq,ge,gt)
1919 -- See Note [Deriving and unboxed types] in TcDeriv
1920 primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty
1921
1922 primLitOps :: String -- The class involved
1923 -> TyCon -- The tycon involved
1924 -> Type -- The type
1925 -> ( LHsExpr RdrName -> LHsExpr RdrName -- Constructs a Q Exp value
1926 , LHsExpr RdrName -> LHsExpr RdrName -- Constructs a boxed value
1927 )
1928 primLitOps str tycon ty = ( assoc_ty_id str tycon litConTbl ty
1929 , \v -> nlHsVar boxRDR `nlHsApp` v
1930 )
1931 where
1932 boxRDR
1933 | ty `eqType` addrPrimTy = unpackCString_RDR
1934 | otherwise = assoc_ty_id str tycon boxConTbl ty
1935
1936 ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
1937 ordOpTbl
1938 = [(charPrimTy , (ltChar_RDR , leChar_RDR , eqChar_RDR , geChar_RDR , gtChar_RDR ))
1939 ,(intPrimTy , (ltInt_RDR , leInt_RDR , eqInt_RDR , geInt_RDR , gtInt_RDR ))
1940 ,(wordPrimTy , (ltWord_RDR , leWord_RDR , eqWord_RDR , geWord_RDR , gtWord_RDR ))
1941 ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR , eqAddr_RDR , geAddr_RDR , gtAddr_RDR ))
1942 ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR , eqFloat_RDR , geFloat_RDR , gtFloat_RDR ))
1943 ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR, eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ]
1944
1945 boxConTbl :: [(Type, RdrName)]
1946 boxConTbl
1947 = [(charPrimTy , getRdrName charDataCon )
1948 ,(intPrimTy , getRdrName intDataCon )
1949 ,(wordPrimTy , getRdrName wordDataCon )
1950 ,(floatPrimTy , getRdrName floatDataCon )
1951 ,(doublePrimTy, getRdrName doubleDataCon)
1952 ]
1953
1954 -- | A table of postfix modifiers for unboxed values.
1955 postfixModTbl :: [(Type, String)]
1956 postfixModTbl
1957 = [(charPrimTy , "#" )
1958 ,(intPrimTy , "#" )
1959 ,(wordPrimTy , "##")
1960 ,(floatPrimTy , "#" )
1961 ,(doublePrimTy, "##")
1962 ]
1963
1964 litConTbl :: [(Type, LHsExpr RdrName -> LHsExpr RdrName)]
1965 litConTbl
1966 = [(charPrimTy , nlHsApp (nlHsVar charPrimL_RDR))
1967 ,(intPrimTy , nlHsApp (nlHsVar intPrimL_RDR)
1968 . nlHsApp (nlHsVar toInteger_RDR))
1969 ,(wordPrimTy , nlHsApp (nlHsVar wordPrimL_RDR)
1970 . nlHsApp (nlHsVar toInteger_RDR))
1971 ,(addrPrimTy , nlHsApp (nlHsVar stringPrimL_RDR)
1972 . nlHsApp (nlHsApp
1973 (nlHsVar map_RDR)
1974 (compose_RDR `nlHsApps`
1975 [ nlHsVar fromIntegral_RDR
1976 , nlHsVar fromEnum_RDR
1977 ])))
1978 ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR)
1979 . nlHsApp (nlHsVar toRational_RDR))
1980 ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR)
1981 . nlHsApp (nlHsVar toRational_RDR))
1982 ]
1983
1984 -- | Lookup `Type` in an association list.
1985 assoc_ty_id :: String -- The class involved
1986 -> TyCon -- The tycon involved
1987 -> [(Type,a)] -- The table
1988 -> Type -- The type
1989 -> a -- The result of the lookup
1990 assoc_ty_id cls_str _ tbl ty
1991 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1992 text "for primitive type" <+> ppr ty)
1993 | otherwise = head res
1994 where
1995 res = [id | (ty',id) <- tbl, ty `eqType` ty']
1996
1997 -----------------------------------------------------------------------
1998
1999 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2000 and_Expr a b = genOpApp a and_RDR b
2001
2002 -----------------------------------------------------------------------
2003
2004 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2005 eq_Expr tycon ty a b
2006 | not (isUnliftedType ty) = genOpApp a eq_RDR b
2007 | otherwise = genPrimOpApp a prim_eq b
2008 where
2009 (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
2010
2011 untag_Expr :: DynFlags -> TyCon -> [( RdrName, RdrName)]
2012 -> LHsExpr RdrName -> LHsExpr RdrName
2013 untag_Expr _ _ [] expr = expr
2014 untag_Expr dflags tycon ((untag_this, put_tag_here) : more) expr
2015 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR dflags tycon)
2016 [untag_this])) {-of-}
2017 [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr dflags tycon more expr)]
2018
2019 enum_from_to_Expr
2020 :: LHsExpr RdrName -> LHsExpr RdrName
2021 -> LHsExpr RdrName
2022 enum_from_then_to_Expr
2023 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2024 -> LHsExpr RdrName
2025
2026 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
2027 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
2028
2029 showParen_Expr
2030 :: LHsExpr RdrName -> LHsExpr RdrName
2031 -> LHsExpr RdrName
2032
2033 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
2034
2035 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
2036
2037 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
2038 nested_compose_Expr [e] = parenify e
2039 nested_compose_Expr (e:es)
2040 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
2041
2042 -- impossible_Expr is used in case RHSs that should never happen.
2043 -- We generate these to keep the desugarer from complaining that they *might* happen!
2044 error_Expr :: String -> LHsExpr RdrName
2045 error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
2046
2047 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
2048 -- method. It is currently only used by Enum.{succ,pred}
2049 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
2050 illegal_Expr meth tp msg =
2051 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
2052
2053 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
2054 -- to include the value of a_RDR in the error string.
2055 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
2056 illegal_toEnum_tag tp maxtag =
2057 nlHsApp (nlHsVar error_RDR)
2058 (nlHsApp (nlHsApp (nlHsVar append_RDR)
2059 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
2060 (nlHsApp (nlHsApp (nlHsApp
2061 (nlHsVar showsPrec_RDR)
2062 (nlHsIntLit 0))
2063 (nlHsVar a_RDR))
2064 (nlHsApp (nlHsApp
2065 (nlHsVar append_RDR)
2066 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
2067 (nlHsApp (nlHsApp (nlHsApp
2068 (nlHsVar showsPrec_RDR)
2069 (nlHsIntLit 0))
2070 (nlHsVar maxtag))
2071 (nlHsLit (mkHsString ")"))))))
2072
2073 parenify :: LHsExpr RdrName -> LHsExpr RdrName
2074 parenify e@(L _ (HsVar _)) = e
2075 parenify e = mkHsPar e
2076
2077 -- genOpApp wraps brackets round the operator application, so that the
2078 -- renamer won't subsequently try to re-associate it.
2079 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2080 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
2081
2082 genPrimOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2083 genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2))
2084
2085 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
2086 :: RdrName
2087 a_RDR = mkVarUnqual (fsLit "a")
2088 b_RDR = mkVarUnqual (fsLit "b")
2089 c_RDR = mkVarUnqual (fsLit "c")
2090 d_RDR = mkVarUnqual (fsLit "d")
2091 f_RDR = mkVarUnqual (fsLit "f")
2092 k_RDR = mkVarUnqual (fsLit "k")
2093 z_RDR = mkVarUnqual (fsLit "z")
2094 ah_RDR = mkVarUnqual (fsLit "a#")
2095 bh_RDR = mkVarUnqual (fsLit "b#")
2096 ch_RDR = mkVarUnqual (fsLit "c#")
2097 dh_RDR = mkVarUnqual (fsLit "d#")
2098
2099 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
2100 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
2101 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
2102 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
2103
2104 a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr,
2105 true_Expr :: LHsExpr RdrName
2106 a_Expr = nlHsVar a_RDR
2107 b_Expr = nlHsVar b_RDR
2108 c_Expr = nlHsVar c_RDR
2109 z_Expr = nlHsVar z_RDR
2110 ltTag_Expr = nlHsVar ltTag_RDR
2111 eqTag_Expr = nlHsVar eqTag_RDR
2112 gtTag_Expr = nlHsVar gtTag_RDR
2113 false_Expr = nlHsVar false_RDR
2114 true_Expr = nlHsVar true_RDR
2115
2116 a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat RdrName
2117 a_Pat = nlVarPat a_RDR
2118 b_Pat = nlVarPat b_RDR
2119 c_Pat = nlVarPat c_RDR
2120 d_Pat = nlVarPat d_RDR
2121 k_Pat = nlVarPat k_RDR
2122 z_Pat = nlVarPat z_RDR
2123
2124 minusInt_RDR, tagToEnum_RDR :: RdrName
2125 minusInt_RDR = getRdrName (primOpId IntSubOp )
2126 tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)
2127
2128 con2tag_RDR, tag2con_RDR, maxtag_RDR :: DynFlags -> TyCon -> RdrName
2129 -- Generates Orig s RdrName, for the binding positions
2130 con2tag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkCon2TagOcc
2131 tag2con_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkTag2ConOcc
2132 maxtag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkMaxTagOcc
2133
2134 mk_tc_deriv_name :: DynFlags -> TyCon -> (OccName -> OccName) -> RdrName
2135 mk_tc_deriv_name dflags tycon occ_fun =
2136 mkAuxBinderName dflags (tyConName tycon) occ_fun
2137
2138 mkAuxBinderName :: DynFlags -> Name -> (OccName -> OccName) -> RdrName
2139 -- ^ Make a top-level binder name for an auxiliary binding for a parent name
2140 -- See Note [Auxiliary binders]
2141 mkAuxBinderName dflags parent occ_fun
2142 = mkRdrUnqual (occ_fun stable_parent_occ)
2143 where
2144 stable_parent_occ = mkOccName (occNameSpace parent_occ) stable_string
2145 stable_string
2146 | hasPprDebug dflags = parent_stable
2147 | otherwise = parent_stable_hash
2148 parent_stable = nameStableString parent
2149 parent_stable_hash =
2150 let Fingerprint high low = fingerprintString parent_stable
2151 in toBase62 high ++ toBase62Padded low
2152 -- See Note [Base 62 encoding 128-bit integers] in Encoding
2153 parent_occ = nameOccName parent
2154
2155
2156 {-
2157 Note [Auxiliary binders]
2158 ~~~~~~~~~~~~~~~~~~~~~~~~
2159 We often want to make a top-level auxiliary binding. E.g. for comparison we haev
2160
2161 instance Ord T where
2162 compare a b = $con2tag a `compare` $con2tag b
2163
2164 $con2tag :: T -> Int
2165 $con2tag = ...code....
2166
2167 Of course these top-level bindings should all have distinct name, and we are
2168 generating RdrNames here. We can't just use the TyCon or DataCon to distinguish
2169 because with standalone deriving two imported TyCons might both be called T!
2170 (See Trac #7947.)
2171
2172 So we use package name, module name and the name of the parent
2173 (T in this example) as part of the OccName we generate for the new binding.
2174 To make the symbol names short we take a base62 hash of the full name.
2175
2176 In the past we used the *unique* from the parent, but that's not stable across
2177 recompilations as uniques are nondeterministic.
2178 -}