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