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