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