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