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