Fix and document cloneWC
[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 noExt (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 noExt
618 (mkIntegralLit (-1 :: Int)))]))
619
620 to_enum dflags
621 = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
622 nlHsIf (nlHsApps and_RDR
623 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
624 nlHsApps le_RDR [ nlHsVar a_RDR
625 , nlHsVar (maxtag_RDR dflags tycon)]])
626 (nlHsVarApps (tag2con_RDR dflags tycon) [a_RDR])
627 (illegal_toEnum_tag occ_nm (maxtag_RDR dflags tycon))
628
629 enum_from dflags
630 = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
631 untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
632 nlHsApps map_RDR
633 [nlHsVar (tag2con_RDR dflags tycon),
634 nlHsPar (enum_from_to_Expr
635 (nlHsVarApps intDataCon_RDR [ah_RDR])
636 (nlHsVar (maxtag_RDR dflags tycon)))]
637
638 enum_from_then dflags
639 = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
640 untag_Expr dflags tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
641 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $
642 nlHsPar (enum_from_then_to_Expr
643 (nlHsVarApps intDataCon_RDR [ah_RDR])
644 (nlHsVarApps intDataCon_RDR [bh_RDR])
645 (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
646 nlHsVarApps intDataCon_RDR [bh_RDR]])
647 (nlHsIntLit 0)
648 (nlHsVar (maxtag_RDR dflags tycon))
649 ))
650
651 from_enum dflags
652 = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
653 untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
654 (nlHsVarApps intDataCon_RDR [ah_RDR])
655
656 {-
657 ************************************************************************
658 * *
659 Bounded instances
660 * *
661 ************************************************************************
662 -}
663
664 gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
665 gen_Bounded_binds loc tycon
666 | isEnumerationTyCon tycon
667 = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
668 | otherwise
669 = ASSERT(isSingleton data_cons)
670 (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)
671 where
672 data_cons = tyConDataCons tycon
673
674 ----- enum-flavored: ---------------------------
675 min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
676 max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
677
678 data_con_1 = head data_cons
679 data_con_N = last data_cons
680 data_con_1_RDR = getRdrName data_con_1
681 data_con_N_RDR = getRdrName data_con_N
682
683 ----- single-constructor-flavored: -------------
684 arity = dataConSourceArity data_con_1
685
686 min_bound_1con = mkHsVarBind loc minBound_RDR $
687 nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
688 max_bound_1con = mkHsVarBind loc maxBound_RDR $
689 nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
690
691 {-
692 ************************************************************************
693 * *
694 Ix instances
695 * *
696 ************************************************************************
697
698 Deriving @Ix@ is only possible for enumeration types and
699 single-constructor types. We deal with them in turn.
700
701 For an enumeration type, e.g.,
702 \begin{verbatim}
703 data Foo ... = N1 | N2 | ... | Nn
704 \end{verbatim}
705 things go not too differently from @Enum@:
706 \begin{verbatim}
707 instance ... Ix (Foo ...) where
708 range (a, b)
709 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
710
711 -- or, really...
712 range (a, b)
713 = case (con2tag_Foo a) of { a# ->
714 case (con2tag_Foo b) of { b# ->
715 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
716 }}
717
718 -- Generate code for unsafeIndex, because using index leads
719 -- to lots of redundant range tests
720 unsafeIndex c@(a, b) d
721 = case (con2tag_Foo d -# con2tag_Foo a) of
722 r# -> I# r#
723
724 inRange (a, b) c
725 = let
726 p_tag = con2tag_Foo c
727 in
728 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
729
730 -- or, really...
731 inRange (a, b) c
732 = case (con2tag_Foo a) of { a_tag ->
733 case (con2tag_Foo b) of { b_tag ->
734 case (con2tag_Foo c) of { c_tag ->
735 if (c_tag >=# a_tag) then
736 c_tag <=# b_tag
737 else
738 False
739 }}}
740 \end{verbatim}
741 (modulo suitable case-ification to handle the unlifted tags)
742
743 For a single-constructor type (NB: this includes all tuples), e.g.,
744 \begin{verbatim}
745 data Foo ... = MkFoo a b Int Double c c
746 \end{verbatim}
747 we follow the scheme given in Figure~19 of the Haskell~1.2 report
748 (p.~147).
749 -}
750
751 gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
752
753 gen_Ix_binds loc tycon = do
754 dflags <- getDynFlags
755 return $ if isEnumerationTyCon tycon
756 then (enum_ixes dflags, listToBag $ map DerivAuxBind
757 [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
758 else (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))
759 where
760 --------------------------------------------------------------
761 enum_ixes dflags = listToBag
762 [ enum_range dflags
763 , enum_index dflags
764 , enum_inRange dflags
765 ]
766
767 enum_range dflags
768 = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
769 untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
770 untag_Expr dflags tycon [(b_RDR, bh_RDR)] $
771 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $
772 nlHsPar (enum_from_to_Expr
773 (nlHsVarApps intDataCon_RDR [ah_RDR])
774 (nlHsVarApps intDataCon_RDR [bh_RDR]))
775
776 enum_index dflags
777 = mk_easy_FunBind loc unsafeIndex_RDR
778 [noLoc (AsPat noExt (noLoc c_RDR)
779 (nlTuplePat [a_Pat, nlWildPat] Boxed)),
780 d_Pat] (
781 untag_Expr dflags tycon [(a_RDR, ah_RDR)] (
782 untag_Expr dflags tycon [(d_RDR, dh_RDR)] (
783 let
784 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
785 in
786 nlHsCase
787 (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
788 [mkHsCaseAlt (nlVarPat c_RDR) rhs]
789 ))
790 )
791
792 -- This produces something like `(ch >= ah) && (ch <= bh)`
793 enum_inRange dflags
794 = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
795 untag_Expr dflags tycon [(a_RDR, ah_RDR)] (
796 untag_Expr dflags tycon [(b_RDR, bh_RDR)] (
797 untag_Expr dflags tycon [(c_RDR, ch_RDR)] (
798 -- This used to use `if`, which interacts badly with RebindableSyntax.
799 -- See #11396.
800 nlHsApps and_RDR
801 [ genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)
802 , genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR)
803 ]
804 )))
805
806 --------------------------------------------------------------
807 single_con_ixes
808 = listToBag [single_con_range, single_con_index, single_con_inRange]
809
810 data_con
811 = case tyConSingleDataCon_maybe tycon of -- just checking...
812 Nothing -> panic "get_Ix_binds"
813 Just dc -> dc
814
815 con_arity = dataConSourceArity data_con
816 data_con_RDR = getRdrName data_con
817
818 as_needed = take con_arity as_RDRs
819 bs_needed = take con_arity bs_RDRs
820 cs_needed = take con_arity cs_RDRs
821
822 con_pat xs = nlConVarPat data_con_RDR xs
823 con_expr = nlHsVarApps data_con_RDR cs_needed
824
825 --------------------------------------------------------------
826 single_con_range
827 = mk_easy_FunBind loc range_RDR
828 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
829 noLoc (mkHsComp ListComp stmts con_expr)
830 where
831 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
832
833 mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
834 (nlHsApp (nlHsVar range_RDR)
835 (mkLHsVarTuple [a,b]))
836
837 ----------------
838 single_con_index
839 = mk_easy_FunBind loc unsafeIndex_RDR
840 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
841 con_pat cs_needed]
842 -- We need to reverse the order we consider the components in
843 -- so that
844 -- range (l,u) !! index (l,u) i == i -- when i is in range
845 -- (from http://haskell.org/onlinereport/ix.html) holds.
846 (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
847 where
848 -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
849 mk_index [] = nlHsIntLit 0
850 mk_index [(l,u,i)] = mk_one l u i
851 mk_index ((l,u,i) : rest)
852 = genOpApp (
853 mk_one l u i
854 ) plus_RDR (
855 genOpApp (
856 (nlHsApp (nlHsVar unsafeRangeSize_RDR)
857 (mkLHsVarTuple [l,u]))
858 ) times_RDR (mk_index rest)
859 )
860 mk_one l u i
861 = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i]
862
863 ------------------
864 single_con_inRange
865 = mk_easy_FunBind loc inRange_RDR
866 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
867 con_pat cs_needed] $
868 if con_arity == 0
869 -- If the product type has no fields, inRange is trivially true
870 -- (see Trac #12853).
871 then true_Expr
872 else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range
873 as_needed bs_needed cs_needed)
874 where
875 in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
876
877 {-
878 ************************************************************************
879 * *
880 Read instances
881 * *
882 ************************************************************************
883
884 Example
885
886 infix 4 %%
887 data T = Int %% Int
888 | T1 { f1 :: Int }
889 | T2 T
890
891 instance Read T where
892 readPrec =
893 parens
894 ( prec 4 (
895 do x <- ReadP.step Read.readPrec
896 expectP (Symbol "%%")
897 y <- ReadP.step Read.readPrec
898 return (x %% y))
899 +++
900 prec (appPrec+1) (
901 -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
902 -- Record construction binds even more tightly than application
903 do expectP (Ident "T1")
904 expectP (Punc '{')
905 x <- Read.readField "f1" (ReadP.reset 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 rhs
967 where
968 rhs | null data_cons -- See Note [Read for empty data types]
969 = nlHsVar pfail_RDR
970 | otherwise
971 = nlHsApp (nlHsVar parens_RDR)
972 (foldr1 mk_alt (read_nullary_cons ++
973 read_non_nullary_cons))
974
975 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
976
977 read_nullary_cons
978 = case nullary_cons of
979 [] -> []
980 [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])]
981 _ -> [nlHsApp (nlHsVar choose_RDR)
982 (nlList (map mk_pair nullary_cons))]
983 -- NB For operators the parens around (:=:) are matched by the
984 -- enclosing "parens" call, so here we must match the naked
985 -- data_con_str con
986
987 match_con con | isSym con_str = [symbol_pat con_str]
988 | otherwise = ident_h_pat con_str
989 where
990 con_str = data_con_str con
991 -- For nullary constructors we must match Ident s for normal constrs
992 -- and Symbol s for operators
993
994 mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),
995 result_expr con []]
996
997 read_non_nullary_con data_con
998 | is_infix = mk_parser infix_prec infix_stmts body
999 | is_record = mk_parser record_prec record_stmts body
1000 -- Using these two lines instead allows the derived
1001 -- read for infix and record bindings to read the prefix form
1002 -- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body)
1003 -- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
1004 | otherwise = prefix_parser
1005 where
1006 body = result_expr data_con as_needed
1007 con_str = data_con_str data_con
1008
1009 prefix_parser = mk_parser prefix_prec prefix_stmts body
1010
1011 read_prefix_con
1012 | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"]
1013 | otherwise = ident_h_pat con_str
1014
1015 read_infix_con
1016 | isSym con_str = [symbol_pat con_str]
1017 | otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"]
1018
1019 prefix_stmts -- T a b c
1020 = read_prefix_con ++ read_args
1021
1022 infix_stmts -- a %% b, or a `T` b
1023 = [read_a1]
1024 ++ read_infix_con
1025 ++ [read_a2]
1026
1027 record_stmts -- T { f1 = a, f2 = b }
1028 = read_prefix_con
1029 ++ [read_punc "{"]
1030 ++ concat (intersperse [read_punc ","] field_stmts)
1031 ++ [read_punc "}"]
1032
1033 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
1034
1035 con_arity = dataConSourceArity data_con
1036 labels = map flLabel $ dataConFieldLabels data_con
1037 dc_nm = getName data_con
1038 is_infix = dataConIsInfix data_con
1039 is_record = labels `lengthExceeds` 0
1040 as_needed = take con_arity as_RDRs
1041 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
1042 (read_a1:read_a2:_) = read_args
1043
1044 prefix_prec = appPrecedence
1045 infix_prec = getPrecedence get_fixity dc_nm
1046 record_prec = appPrecedence + 1 -- Record construction binds even more tightly
1047 -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
1048
1049 ------------------------------------------------------------------------
1050 -- Helpers
1051 ------------------------------------------------------------------------
1052 mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
1053 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b })
1054 , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])]
1055 con_app con as = nlHsVarApps (getRdrName con) as -- con as
1056 result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
1057
1058 -- For constructors and field labels ending in '#', we hackily
1059 -- let the lexer generate two tokens, and look for both in sequence
1060 -- Thus [Ident "I"; Symbol "#"]. See Trac #5041
1061 ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ]
1062 | otherwise = [ ident_pat s ]
1063
1064 bindLex pat = noLoc (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat)) -- expectP p
1065 -- See Note [Use expectP]
1066 ident_pat s = bindLex $ nlHsApps ident_RDR [nlHsLit (mkHsString s)] -- expectP (Ident "foo")
1067 symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)] -- expectP (Symbol ">>")
1068 read_punc c = bindLex $ nlHsApps punc_RDR [nlHsLit (mkHsString c)] -- expectP (Punc "<")
1069
1070 data_con_str con = occNameString (getOccName con)
1071
1072 read_arg a ty = ASSERT( not (isUnliftedType ty) )
1073 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_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_field lbl a =
1081 [noLoc
1082 (mkBindStmt
1083 (nlVarPat a)
1084 (nlHsApp
1085 read_field
1086 (nlHsVarApps reset_RDR [readPrec_RDR])
1087 )
1088 )
1089 ]
1090 where
1091 lbl_str = unpackFS lbl
1092 mk_read_field read_field_rdr lbl
1093 = nlHsApps read_field_rdr [nlHsLit (mkHsString lbl)]
1094 read_field
1095 | isSym lbl_str
1096 = mk_read_field readSymField_RDR lbl_str
1097 | Just (ss, '#') <- snocView lbl_str -- #14918
1098 = mk_read_field readFieldHash_RDR ss
1099 | otherwise
1100 = mk_read_field readField_RDR lbl_str
1101
1102 {-
1103 ************************************************************************
1104 * *
1105 Show instances
1106 * *
1107 ************************************************************************
1108
1109 Example
1110
1111 infixr 5 :^:
1112
1113 data Tree a = Leaf a | Tree a :^: Tree a
1114
1115 instance (Show a) => Show (Tree a) where
1116
1117 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
1118 where
1119 showStr = showString "Leaf " . showsPrec (app_prec+1) m
1120
1121 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
1122 where
1123 showStr = showsPrec (up_prec+1) u .
1124 showString " :^: " .
1125 showsPrec (up_prec+1) v
1126 -- Note: right-associativity of :^: ignored
1127
1128 up_prec = 5 -- Precedence of :^:
1129 app_prec = 10 -- Application has precedence one more than
1130 -- the most tightly-binding operator
1131 -}
1132
1133 gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon
1134 -> (LHsBinds GhcPs, BagDerivStuff)
1135
1136 gen_Show_binds get_fixity loc tycon
1137 = (unitBag shows_prec, emptyBag)
1138 where
1139 data_cons = tyConDataCons tycon
1140 shows_prec = mkFunBindEC 2 loc showsPrec_RDR id (map pats_etc data_cons)
1141 comma_space = nlHsVar showCommaSpace_RDR
1142
1143 pats_etc data_con
1144 | nullary_con = -- skip the showParen junk...
1145 ASSERT(null bs_needed)
1146 ([nlWildPat, con_pat], mk_showString_app op_con_str)
1147 | otherwise =
1148 ([a_Pat, con_pat],
1149 showParen_Expr (genOpApp a_Expr ge_RDR (nlHsLit
1150 (HsInt noExt (mkIntegralLit con_prec_plus_one))))
1151 (nlHsPar (nested_compose_Expr show_thingies)))
1152 where
1153 data_con_RDR = getRdrName data_con
1154 con_arity = dataConSourceArity data_con
1155 bs_needed = take con_arity bs_RDRs
1156 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
1157 con_pat = nlConVarPat data_con_RDR bs_needed
1158 nullary_con = con_arity == 0
1159 labels = map flLabel $ dataConFieldLabels data_con
1160 lab_fields = length labels
1161 record_syntax = lab_fields > 0
1162
1163 dc_nm = getName data_con
1164 dc_occ_nm = getOccName data_con
1165 con_str = occNameString dc_occ_nm
1166 op_con_str = wrapOpParens con_str
1167 backquote_str = wrapOpBackquotes con_str
1168
1169 show_thingies
1170 | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
1171 | record_syntax = mk_showString_app (op_con_str ++ " {") :
1172 show_record_args ++ [mk_showString_app "}"]
1173 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
1174
1175 show_label l = mk_showString_app (nm ++ " = ")
1176 -- Note the spaces around the "=" sign. If we
1177 -- don't have them then we get Foo { x=-1 } and
1178 -- the "=-" parses as a single lexeme. Only the
1179 -- space after the '=' is necessary, but it
1180 -- seems tidier to have them both sides.
1181 where
1182 nm = wrapOpParens (unpackFS l)
1183
1184 show_args = zipWith show_arg bs_needed arg_tys
1185 (show_arg1:show_arg2:_) = show_args
1186 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
1187
1188 -- Assumption for record syntax: no of fields == no of
1189 -- labelled fields (and in same order)
1190 show_record_args = concat $
1191 intersperse [comma_space] $
1192 [ [show_label lbl, arg]
1193 | (lbl,arg) <- zipEqual "gen_Show_binds"
1194 labels show_args ]
1195
1196 show_arg :: RdrName -> Type -> LHsExpr GhcPs
1197 show_arg b arg_ty
1198 | isUnliftedType arg_ty
1199 -- See Note [Deriving and unboxed types] in TcDeriv
1200 = nlHsApps compose_RDR [mk_shows_app boxed_arg,
1201 mk_showString_app postfixMod]
1202 | otherwise
1203 = mk_showsPrec_app arg_prec arg
1204 where
1205 arg = nlHsVar b
1206 boxed_arg = box "Show" tycon arg arg_ty
1207 postfixMod = assoc_ty_id "Show" tycon postfixModTbl arg_ty
1208
1209 -- Fixity stuff
1210 is_infix = dataConIsInfix data_con
1211 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1212 arg_prec | record_syntax = 0 -- Record fields don't need parens
1213 | otherwise = con_prec_plus_one
1214
1215 wrapOpParens :: String -> String
1216 wrapOpParens s | isSym s = '(' : s ++ ")"
1217 | otherwise = s
1218
1219 wrapOpBackquotes :: String -> String
1220 wrapOpBackquotes s | isSym s = s
1221 | otherwise = '`' : s ++ "`"
1222
1223 isSym :: String -> Bool
1224 isSym "" = False
1225 isSym (c : _) = startsVarSym c || startsConSym c
1226
1227 -- | showString :: String -> ShowS
1228 mk_showString_app :: String -> LHsExpr GhcPs
1229 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1230
1231 -- | showsPrec :: Show a => Int -> a -> ShowS
1232 mk_showsPrec_app :: Integer -> LHsExpr GhcPs -> LHsExpr GhcPs
1233 mk_showsPrec_app p x
1234 = nlHsApps showsPrec_RDR [nlHsLit (HsInt noExt (mkIntegralLit p)), x]
1235
1236 -- | shows :: Show a => a -> ShowS
1237 mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs
1238 mk_shows_app x = nlHsApp (nlHsVar shows_RDR) x
1239
1240 getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer
1241 getPrec is_infix get_fixity nm
1242 | not is_infix = appPrecedence
1243 | otherwise = getPrecedence get_fixity nm
1244
1245 appPrecedence :: Integer
1246 appPrecedence = fromIntegral maxPrecedence + 1
1247 -- One more than the precedence of the most
1248 -- tightly-binding operator
1249
1250 getPrecedence :: (Name -> Fixity) -> Name -> Integer
1251 getPrecedence get_fixity nm
1252 = case get_fixity nm of
1253 Fixity _ x _assoc -> fromIntegral x
1254 -- NB: the Report says that associativity is not taken
1255 -- into account for either Read or Show; hence we
1256 -- ignore associativity here
1257
1258 {-
1259 ************************************************************************
1260 * *
1261 Data instances
1262 * *
1263 ************************************************************************
1264
1265 From the data type
1266
1267 data T a b = T1 a b | T2
1268
1269 we generate
1270
1271 $cT1 = mkDataCon $dT "T1" Prefix
1272 $cT2 = mkDataCon $dT "T2" Prefix
1273 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1274 -- the [] is for field labels.
1275
1276 instance (Data a, Data b) => Data (T a b) where
1277 gfoldl k z (T1 a b) = z T `k` a `k` b
1278 gfoldl k z T2 = z T2
1279 -- ToDo: add gmapT,Q,M, gfoldr
1280
1281 gunfold k z c = case conIndex c of
1282 I# 1# -> k (k (z T1))
1283 I# 2# -> z T2
1284
1285 toConstr (T1 _ _) = $cT1
1286 toConstr T2 = $cT2
1287
1288 dataTypeOf _ = $dT
1289
1290 dataCast1 = gcast1 -- If T :: * -> *
1291 dataCast2 = gcast2 -- if T :: * -> * -> *
1292 -}
1293
1294 gen_Data_binds :: SrcSpan
1295 -> TyCon -- For data families, this is the
1296 -- *representation* TyCon
1297 -> TcM (LHsBinds GhcPs, -- The method bindings
1298 BagDerivStuff) -- Auxiliary bindings
1299 gen_Data_binds loc rep_tc
1300 = do { dflags <- getDynFlags
1301
1302 -- Make unique names for the data type and constructor
1303 -- auxiliary bindings. Start with the name of the TyCon/DataCon
1304 -- but that might not be unique: see Trac #12245.
1305 ; dt_occ <- chooseUniqueOccTc (mkDataTOcc (getOccName rep_tc))
1306 ; dc_occs <- mapM (chooseUniqueOccTc . mkDataCOcc . getOccName)
1307 (tyConDataCons rep_tc)
1308 ; let dt_rdr = mkRdrUnqual dt_occ
1309 dc_rdrs = map mkRdrUnqual dc_occs
1310
1311 -- OK, now do the work
1312 ; return (gen_data dflags dt_rdr dc_rdrs loc rep_tc) }
1313
1314 gen_data :: DynFlags -> RdrName -> [RdrName]
1315 -> SrcSpan -> TyCon
1316 -> (LHsBinds GhcPs, -- The method bindings
1317 BagDerivStuff) -- Auxiliary bindings
1318 gen_data dflags data_type_name constr_names loc rep_tc
1319 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
1320 `unionBags` gcast_binds,
1321 -- Auxiliary definitions: the data type and constructors
1322 listToBag ( genDataTyCon
1323 : zipWith genDataDataCon data_cons constr_names ) )
1324 where
1325 data_cons = tyConDataCons rep_tc
1326 n_cons = length data_cons
1327 one_constr = n_cons == 1
1328 genDataTyCon :: DerivStuff
1329 genDataTyCon -- $dT
1330 = DerivHsBind (mkHsVarBind loc data_type_name rhs,
1331 L loc (TypeSig noExt [L loc data_type_name] sig_ty))
1332
1333 sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR)
1334 rhs = nlHsVar mkDataType_RDR
1335 `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc)))
1336 `nlHsApp` nlList (map nlHsVar constr_names)
1337
1338 genDataDataCon :: DataCon -> RdrName -> DerivStuff
1339 genDataDataCon dc constr_name -- $cT1 etc
1340 = DerivHsBind (mkHsVarBind loc constr_name rhs,
1341 L loc (TypeSig noExt [L loc constr_name] sig_ty))
1342 where
1343 sig_ty = mkLHsSigWcType (nlHsTyVar constr_RDR)
1344 rhs = nlHsApps mkConstr_RDR constr_args
1345
1346 constr_args
1347 = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1348 nlHsVar (data_type_name) -- DataType
1349 , nlHsLit (mkHsString (occNameString dc_occ)) -- String name
1350 , nlList labels -- Field labels
1351 , nlHsVar fixity ] -- Fixity
1352
1353 labels = map (nlHsLit . mkHsString . unpackFS . flLabel)
1354 (dataConFieldLabels dc)
1355 dc_occ = getOccName dc
1356 is_infix = isDataSymOcc dc_occ
1357 fixity | is_infix = infix_RDR
1358 | otherwise = prefix_RDR
1359
1360 ------------ gfoldl
1361 gfoldl_bind = mkFunBindEC 3 loc gfoldl_RDR id (map gfoldl_eqn data_cons)
1362
1363 gfoldl_eqn con
1364 = ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed],
1365 foldl mk_k_app (z_Expr `nlHsApp` nlHsVar con_name) as_needed)
1366 where
1367 con_name :: RdrName
1368 con_name = getRdrName con
1369 as_needed = take (dataConSourceArity con) as_RDRs
1370 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1371
1372 ------------ gunfold
1373 gunfold_bind = mk_easy_FunBind loc
1374 gunfold_RDR
1375 [k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat]
1376 gunfold_rhs
1377
1378 gunfold_rhs
1379 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1380 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1381 (map gunfold_alt data_cons)
1382
1383 gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1384 mk_unfold_rhs dc = foldr nlHsApp
1385 (z_Expr `nlHsApp` nlHsVar (getRdrName dc))
1386 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1387
1388 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1389 -- redundant test, and annoying warning
1390 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1391 | otherwise = nlConPat intDataCon_RDR
1392 [nlLitPat (HsIntPrim NoSourceText (toInteger tag))]
1393 where
1394 tag = dataConTag dc
1395
1396 ------------ toConstr
1397 toCon_bind = mkFunBindEC 1 loc toConstr_RDR id
1398 (zipWith to_con_eqn data_cons constr_names)
1399 to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name)
1400
1401 ------------ dataTypeOf
1402 dataTypeOf_bind = mk_easy_FunBind
1403 loc
1404 dataTypeOf_RDR
1405 [nlWildPat]
1406 (nlHsVar data_type_name)
1407
1408 ------------ gcast1/2
1409 -- Make the binding dataCast1 x = gcast1 x -- if T :: * -> *
1410 -- or dataCast2 x = gcast2 s -- if T :: * -> * -> *
1411 -- (or nothing if T has neither of these two types)
1412
1413 -- But care is needed for data families:
1414 -- If we have data family D a
1415 -- data instance D (a,b,c) = A | B deriving( Data )
1416 -- and we want instance ... => Data (D [(a,b,c)]) where ...
1417 -- then we need dataCast1 x = gcast1 x
1418 -- because D :: * -> *
1419 -- even though rep_tc has kind * -> * -> * -> *
1420 -- Hence looking for the kind of fam_tc not rep_tc
1421 -- See Trac #4896
1422 tycon_kind = case tyConFamInst_maybe rep_tc of
1423 Just (fam_tc, _) -> tyConKind fam_tc
1424 Nothing -> tyConKind rep_tc
1425 gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR
1426 | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
1427 | otherwise = emptyBag
1428 mk_gcast dataCast_RDR gcast_RDR
1429 = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
1430 (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
1431
1432
1433 kind1, kind2 :: Kind
1434 kind1 = liftedTypeKind `mkFunTy` liftedTypeKind
1435 kind2 = liftedTypeKind `mkFunTy` kind1
1436
1437 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
1438 mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
1439 dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,
1440 constr_RDR, dataType_RDR,
1441 eqChar_RDR , ltChar_RDR , geChar_RDR , gtChar_RDR , leChar_RDR ,
1442 eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR ,
1443 eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR ,
1444 eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR ,
1445 eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,
1446 eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR :: RdrName
1447 gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
1448 gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
1449 toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
1450 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1451 dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1")
1452 dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2")
1453 gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1")
1454 gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2")
1455 mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
1456 constr_RDR = tcQual_RDR gENERICS (fsLit "Constr")
1457 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1458 dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType")
1459 conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
1460 prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix")
1461 infix_RDR = dataQual_RDR gENERICS (fsLit "Infix")
1462
1463 eqChar_RDR = varQual_RDR gHC_PRIM (fsLit "eqChar#")
1464 ltChar_RDR = varQual_RDR gHC_PRIM (fsLit "ltChar#")
1465 leChar_RDR = varQual_RDR gHC_PRIM (fsLit "leChar#")
1466 gtChar_RDR = varQual_RDR gHC_PRIM (fsLit "gtChar#")
1467 geChar_RDR = varQual_RDR gHC_PRIM (fsLit "geChar#")
1468
1469 eqInt_RDR = varQual_RDR gHC_PRIM (fsLit "==#")
1470 ltInt_RDR = varQual_RDR gHC_PRIM (fsLit "<#" )
1471 leInt_RDR = varQual_RDR gHC_PRIM (fsLit "<=#")
1472 gtInt_RDR = varQual_RDR gHC_PRIM (fsLit ">#" )
1473 geInt_RDR = varQual_RDR gHC_PRIM (fsLit ">=#")
1474
1475 eqWord_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord#")
1476 ltWord_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord#")
1477 leWord_RDR = varQual_RDR gHC_PRIM (fsLit "leWord#")
1478 gtWord_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord#")
1479 geWord_RDR = varQual_RDR gHC_PRIM (fsLit "geWord#")
1480
1481 eqAddr_RDR = varQual_RDR gHC_PRIM (fsLit "eqAddr#")
1482 ltAddr_RDR = varQual_RDR gHC_PRIM (fsLit "ltAddr#")
1483 leAddr_RDR = varQual_RDR gHC_PRIM (fsLit "leAddr#")
1484 gtAddr_RDR = varQual_RDR gHC_PRIM (fsLit "gtAddr#")
1485 geAddr_RDR = varQual_RDR gHC_PRIM (fsLit "geAddr#")
1486
1487 eqFloat_RDR = varQual_RDR gHC_PRIM (fsLit "eqFloat#")
1488 ltFloat_RDR = varQual_RDR gHC_PRIM (fsLit "ltFloat#")
1489 leFloat_RDR = varQual_RDR gHC_PRIM (fsLit "leFloat#")
1490 gtFloat_RDR = varQual_RDR gHC_PRIM (fsLit "gtFloat#")
1491 geFloat_RDR = varQual_RDR gHC_PRIM (fsLit "geFloat#")
1492
1493 eqDouble_RDR = varQual_RDR gHC_PRIM (fsLit "==##")
1494 ltDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<##" )
1495 leDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<=##")
1496 gtDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">##" )
1497 geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##")
1498
1499 {-
1500 ************************************************************************
1501 * *
1502 Lift instances
1503 * *
1504 ************************************************************************
1505
1506 Example:
1507
1508 data Foo a = Foo a | a :^: a deriving Lift
1509
1510 ==>
1511
1512 instance (Lift a) => Lift (Foo a) where
1513 lift (Foo a)
1514 = appE
1515 (conE
1516 (mkNameG_d "package-name" "ModuleName" "Foo"))
1517 (lift a)
1518 lift (u :^: v)
1519 = infixApp
1520 (lift u)
1521 (conE
1522 (mkNameG_d "package-name" "ModuleName" ":^:"))
1523 (lift v)
1524
1525 Note that (mkNameG_d "package-name" "ModuleName" "Foo") is equivalent to what
1526 'Foo would be when using the -XTemplateHaskell extension. To make sure that
1527 -XDeriveLift can be used on stage-1 compilers, however, we explicitly invoke
1528 makeG_d.
1529 -}
1530
1531 gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
1532 gen_Lift_binds loc tycon = (unitBag lift_bind, emptyBag)
1533 where
1534 lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)
1535 (map pats_etc data_cons)
1536 data_cons = tyConDataCons tycon
1537
1538 pats_etc data_con
1539 = ([con_pat], lift_Expr)
1540 where
1541 con_pat = nlConVarPat data_con_RDR as_needed
1542 data_con_RDR = getRdrName data_con
1543 con_arity = dataConSourceArity data_con
1544 as_needed = take con_arity as_RDRs
1545 lifted_as = zipWithEqual "mk_lift_app" mk_lift_app
1546 tys_needed as_needed
1547 tycon_name = tyConName tycon
1548 is_infix = dataConIsInfix data_con
1549 tys_needed = dataConOrigArgTys data_con
1550
1551 mk_lift_app ty a
1552 | not (isUnliftedType ty) = nlHsApp (nlHsVar lift_RDR)
1553 (nlHsVar a)
1554 | otherwise = nlHsApp (nlHsVar litE_RDR)
1555 (primLitOp (mkBoxExp (nlHsVar a)))
1556 where (primLitOp, mkBoxExp) = primLitOps "Lift" tycon ty
1557
1558 pkg_name = unitIdString . moduleUnitId
1559 . nameModule $ tycon_name
1560 mod_name = moduleNameString . moduleName . nameModule $ tycon_name
1561 con_name = occNameString . nameOccName . dataConName $ data_con
1562
1563 conE_Expr = nlHsApp (nlHsVar conE_RDR)
1564 (nlHsApps mkNameG_dRDR
1565 (map (nlHsLit . mkHsString)
1566 [pkg_name, mod_name, con_name]))
1567
1568 lift_Expr
1569 | is_infix = nlHsApps infixApp_RDR [a1, conE_Expr, a2]
1570 | otherwise = foldl mk_appE_app conE_Expr lifted_as
1571 (a1:a2:_) = lifted_as
1572
1573 mk_appE_app :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
1574 mk_appE_app a b = nlHsApps appE_RDR [a, b]
1575
1576 {-
1577 ************************************************************************
1578 * *
1579 Newtype-deriving instances
1580 * *
1581 ************************************************************************
1582
1583 Note [Newtype-deriving instances]
1584 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1585 We take every method in the original instance and `coerce` it to fit
1586 into the derived instance. We need type applications on the argument
1587 to `coerce` to make it obvious what instantiation of the method we're
1588 coercing from. So from, say,
1589
1590 class C a b where
1591 op :: forall c. a -> [b] -> c -> Int
1592
1593 newtype T x = MkT <rep-ty>
1594
1595 instance C a <rep-ty> => C a (T x) where
1596 op = coerce @ (a -> [<rep-ty>] -> c -> Int)
1597 @ (a -> [T x] -> c -> Int)
1598 op :: forall c. a -> [T x] -> c -> Int
1599
1600 In addition to the type applications, we also have an explicit
1601 type signature on the entire RHS. This brings the method-bound variable
1602 `c` into scope over the two type applications.
1603 See Note [GND and QuantifiedConstraints] for more information on why this
1604 is important.
1605
1606 Giving 'coerce' two explicitly-visible type arguments grants us finer control
1607 over how it should be instantiated. Recall
1608
1609 coerce :: Coercible a b => a -> b
1610
1611 By giving it explicit type arguments we deal with the case where
1612 'op' has a higher rank type, and so we must instantiate 'coerce' with
1613 a polytype. E.g.
1614
1615 class C a where op :: a -> forall b. b -> b
1616 newtype T x = MkT <rep-ty>
1617 instance C <rep-ty> => C (T x) where
1618 op = coerce @ (<rep-ty> -> forall b. b -> b)
1619 @ (T x -> forall b. b -> b)
1620 op :: T x -> forall b. b -> b
1621
1622 The use of type applications is crucial here. If we had tried using only
1623 explicit type signatures, like so:
1624
1625 instance C <rep-ty> => C (T x) where
1626 op = coerce (op :: <rep-ty> -> forall b. b -> b)
1627 :: T x -> forall b. b -> b
1628
1629 Then GHC will attempt to deeply skolemize the two type signatures, which will
1630 wreak havoc with the Coercible solver. Therefore, we instead use type
1631 applications, which do not deeply skolemize and thus avoid this issue.
1632 The downside is that we currently require -XImpredicativeTypes to permit this
1633 polymorphic type instantiation, so we have to switch that flag on locally in
1634 TcDeriv.genInst. See #8503 for more discussion.
1635
1636 Note [Newtype-deriving trickiness]
1637 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1638 Consider (Trac #12768):
1639 class C a where { op :: D a => a -> a }
1640
1641 instance C a => C [a] where { op = opList }
1642
1643 opList :: (C a, D [a]) => [a] -> [a]
1644 opList = ...
1645
1646 Now suppose we try GND on this:
1647 newtype N a = MkN [a] deriving( C )
1648
1649 The GND is expecting to get an implementation of op for N by
1650 coercing opList, thus:
1651
1652 instance C a => C (N a) where { op = opN }
1653
1654 opN :: (C a, D (N a)) => N a -> N a
1655 opN = coerce @([a] -> [a])
1656 @([N a] -> [N a]
1657 opList :: D (N a) => [N a] -> [N a]
1658
1659 But there is no reason to suppose that (D [a]) and (D (N a))
1660 are inter-coercible; these instances might completely different.
1661 So GHC rightly rejects this code.
1662
1663 Note [GND and QuantifiedConstraints]
1664 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1665 Consider the following example from #15290:
1666
1667 class C m where
1668 join :: m (m a) -> m a
1669
1670 newtype T m a = MkT (m a)
1671
1672 deriving instance
1673 (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
1674 C (T m)
1675
1676 The code that GHC used to generate for this was:
1677
1678 instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
1679 C (T m) where
1680 join = coerce @(forall a. m (m a) -> m a)
1681 @(forall a. T m (T m a) -> T m a)
1682 join
1683
1684 This instantiates `coerce` at a polymorphic type, a form of impredicative
1685 polymorphism, so we're already on thin ice. And in fact the ice breaks,
1686 as we'll explain:
1687
1688 The call to `coerce` gives rise to:
1689
1690 Coercible (forall a. m (m a) -> m a)
1691 (forall a. T m (T m a) -> T m a)
1692
1693 And that simplified to the following implication constraint:
1694
1695 forall a <no-ev>. m (T m a) ~R# m (m a)
1696
1697 But because this constraint is under a `forall`, inside a type, we have to
1698 prove it *without computing any term evidence* (hence the <no-ev>). Alas, we
1699 *must* generate a term-level evidence binding in order to instantiate the
1700 quantified constraint! In response, GHC currently chooses not to use such
1701 a quantified constraint.
1702 See Note [Instances in no-evidence implications] in TcInteract.
1703
1704 But this isn't the death knell for combining QuantifiedConstraints with GND.
1705 On the contrary, if we generate GND bindings in a slightly different way, then
1706 we can avoid this situation altogether. Instead of applying `coerce` to two
1707 polymorphic types, we instead let an explicit type signature do the polymorphic
1708 instantiation, and omit the `forall`s in the type applications.
1709 More concretely, we generate the following code instead:
1710
1711 instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
1712 C (T m) where
1713 join = coerce @( m (m a) -> m a)
1714 @(T m (T m a) -> T m a)
1715 join :: forall a. T m (T m a) -> T m a
1716
1717 Now the visible type arguments are both monotypes, so we need do any of this
1718 funny quantified constraint instantiation business.
1719
1720 You might think that that second @(T m (T m a) -> T m a) argument is redundant
1721 in the presence of the explicit `:: forall a. T m (T m a) -> T m a` type
1722 signature, but in fact leaving it off will break this example (from the
1723 T15290d test case):
1724
1725 class C a where
1726 c :: Int -> forall b. b -> a
1727
1728 instance C Int
1729
1730 instance C Age where
1731 c = coerce @(Int -> forall b. b -> Int)
1732 c :: Int -> forall b. b -> Age
1733
1734 That is because the explicit type signature deeply skolemizes the forall-bound
1735 `b`, which wreaks havoc with the `Coercible` solver. An additional visible type
1736 argument of @(Int -> forall b. b -> Age) is enough to prevent this.
1737
1738 Be aware that the use of an explicit type signature doesn't /solve/ this
1739 problem; it just makes it less likely to occur. For example, if a class has
1740 a truly higher-rank type like so:
1741
1742 class CProblem m where
1743 op :: (forall b. ... (m b) ...) -> Int
1744
1745 Then the same situation will arise again. But at least it won't arise for the
1746 common case of methods with ordinary, prenex-quantified types.
1747 -}
1748
1749 gen_Newtype_binds :: SrcSpan
1750 -> Class -- the class being derived
1751 -> [TyVar] -- the tvs in the instance head (this includes
1752 -- the tvs from both the class types and the
1753 -- newtype itself)
1754 -> [Type] -- instance head parameters (incl. newtype)
1755 -> Type -- the representation type
1756 -> TcM (LHsBinds GhcPs, BagDerivStuff)
1757 -- See Note [Newtype-deriving instances]
1758 gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
1759 = do let ats = classATs cls
1760 atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats )
1761 mapM mk_atf_inst ats
1762 return ( listToBag $ map mk_bind (classMethods cls)
1763 , listToBag $ map DerivFamInst atf_insts )
1764 where
1765 mk_bind :: Id -> LHsBind GhcPs
1766 mk_bind meth_id
1767 = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch
1768 (mkPrefixFunRhs (L loc meth_RDR))
1769 [] rhs_expr]
1770 where
1771 Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id
1772 (_, _, from_tau) = tcSplitSigmaTy from_ty
1773 (_, _, to_tau) = tcSplitSigmaTy to_ty
1774
1775 meth_RDR = getRdrName meth_id
1776
1777 rhs_expr = nlHsVar (getRdrName coerceId)
1778 `nlHsAppType` from_tau
1779 `nlHsAppType` to_tau
1780 `nlHsApp` nlHsVar meth_RDR
1781 `nlExprWithTySig` to_ty
1782
1783 mk_atf_inst :: TyCon -> TcM FamInst
1784 mk_atf_inst fam_tc = do
1785 rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc))
1786 rep_lhs_tys
1787 let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' rep_cvs'
1788 fam_tc rep_lhs_tys rep_rhs_ty
1789 -- Check (c) from Note [GND and associated type families] in TcDeriv
1790 checkValidTyFamEqn (Just (cls, cls_tvs, lhs_env)) fam_tc rep_tvs'
1791 rep_cvs' rep_lhs_tys rep_rhs_ty pp_lhs loc
1792 newFamInst SynFamilyInst axiom
1793 where
1794 cls_tvs = classTyVars cls
1795 in_scope = mkInScopeSet $ mkVarSet inst_tvs
1796 lhs_env = zipTyEnv cls_tvs inst_tys
1797 lhs_subst = mkTvSubst in_scope lhs_env
1798 rhs_env = zipTyEnv cls_tvs $ changeLast inst_tys rhs_ty
1799 rhs_subst = mkTvSubst in_scope rhs_env
1800 fam_tvs = tyConTyVars fam_tc
1801 rep_lhs_tys = substTyVars lhs_subst fam_tvs
1802 rep_rhs_tys = substTyVars rhs_subst fam_tvs
1803 rep_rhs_ty = mkTyConApp fam_tc rep_rhs_tys
1804 rep_tcvs = tyCoVarsOfTypesList rep_lhs_tys
1805 (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs
1806 rep_tvs' = toposortTyVars rep_tvs
1807 rep_cvs' = toposortTyVars rep_cvs
1808 pp_lhs = ppr (mkTyConApp fam_tc rep_lhs_tys)
1809
1810 nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
1811 nlHsAppType e s = noLoc (HsAppType hs_ty e)
1812 where
1813 hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec (typeToLHsType s)
1814
1815 nlExprWithTySig :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
1816 nlExprWithTySig e s = noLoc $ ExprWithTySig hs_ty
1817 $ parenthesizeHsExpr sigPrec e
1818 where
1819 hs_ty = mkLHsSigWcType (typeToLHsType s)
1820
1821 mkCoerceClassMethEqn :: Class -- the class being derived
1822 -> [TyVar] -- the tvs in the instance head (this includes
1823 -- the tvs from both the class types and the
1824 -- newtype itself)
1825 -> [Type] -- instance head parameters (incl. newtype)
1826 -> Type -- the representation type
1827 -> Id -- the method to look at
1828 -> Pair Type
1829 -- See Note [Newtype-deriving instances]
1830 -- See also Note [Newtype-deriving trickiness]
1831 -- The pair is the (from_type, to_type), where to_type is
1832 -- the type of the method we are tyrying to get
1833 mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty id
1834 = Pair (substTy rhs_subst user_meth_ty)
1835 (substTy lhs_subst user_meth_ty)
1836 where
1837 cls_tvs = classTyVars cls
1838 in_scope = mkInScopeSet $ mkVarSet inst_tvs
1839 lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs inst_tys)
1840 rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast inst_tys rhs_ty))
1841 (_class_tvs, _class_constraint, user_meth_ty)
1842 = tcSplitMethodTy (varType id)
1843
1844 {-
1845 ************************************************************************
1846 * *
1847 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1848 * *
1849 ************************************************************************
1850
1851 \begin{verbatim}
1852 data Foo ... = ...
1853
1854 con2tag_Foo :: Foo ... -> Int#
1855 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1856 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1857 \end{verbatim}
1858
1859 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1860 fiddling around.
1861 -}
1862
1863 genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec
1864 -> (LHsBind GhcPs, LSig GhcPs)
1865 genAuxBindSpec dflags loc (DerivCon2Tag tycon)
1866 = (mkFunBindSE 0 loc rdr_name eqns,
1867 L loc (TypeSig noExt [L loc rdr_name] sig_ty))
1868 where
1869 rdr_name = con2tag_RDR dflags tycon
1870
1871 sig_ty = mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $
1872 mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
1873 mkParentType tycon `mkFunTy` intPrimTy
1874
1875 lots_of_constructors = tyConFamilySize tycon > 8
1876 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1877 -- but we don't do vectored returns any more.
1878
1879 eqns | lots_of_constructors = [get_tag_eqn]
1880 | otherwise = map mk_eqn (tyConDataCons tycon)
1881
1882 get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
1883
1884 mk_eqn :: DataCon -> ([LPat GhcPs], LHsExpr GhcPs)
1885 mk_eqn con = ([nlWildConPat con],
1886 nlHsLit (HsIntPrim NoSourceText
1887 (toInteger ((dataConTag con) - fIRST_TAG))))
1888
1889 genAuxBindSpec dflags loc (DerivTag2Con tycon)
1890 = (mkFunBindSE 0 loc rdr_name
1891 [([nlConVarPat intDataCon_RDR [a_RDR]],
1892 nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
1893 L loc (TypeSig noExt [L loc rdr_name] sig_ty))
1894 where
1895 sig_ty = mkLHsSigWcType $ L loc $
1896 XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
1897 intTy `mkFunTy` mkParentType tycon
1898
1899 rdr_name = tag2con_RDR dflags tycon
1900
1901 genAuxBindSpec dflags loc (DerivMaxTag tycon)
1902 = (mkHsVarBind loc rdr_name rhs,
1903 L loc (TypeSig noExt [L loc rdr_name] sig_ty))
1904 where
1905 rdr_name = maxtag_RDR dflags tycon
1906 sig_ty = mkLHsSigWcType (L loc (XHsType (NHsCoreTy intTy)))
1907 rhs = nlHsApp (nlHsVar intDataCon_RDR)
1908 (nlHsLit (HsIntPrim NoSourceText max_tag))
1909 max_tag = case (tyConDataCons tycon) of
1910 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1911
1912 type SeparateBagsDerivStuff =
1913 -- AuxBinds and SYB bindings
1914 ( Bag (LHsBind GhcPs, LSig GhcPs)
1915 -- Extra family instances (used by Generic and DeriveAnyClass)
1916 , Bag (FamInst) )
1917
1918 genAuxBinds :: DynFlags -> SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
1919 genAuxBinds dflags loc b = genAuxBinds' b2 where
1920 (b1,b2) = partitionBagWith splitDerivAuxBind b
1921 splitDerivAuxBind (DerivAuxBind x) = Left x
1922 splitDerivAuxBind x = Right x
1923
1924 rm_dups = foldrBag dup_check emptyBag
1925 dup_check a b = if anyBag (== a) b then b else consBag a b
1926
1927 genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
1928 genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec dflags loc) (rm_dups b1)
1929 , emptyBag )
1930 f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
1931 f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
1932 f (DerivHsBind b) = add1 b
1933 f (DerivFamInst t) = add2 t
1934
1935 add1 x (a,b) = (x `consBag` a,b)
1936 add2 x (a,b) = (a,x `consBag` b)
1937
1938 mkParentType :: TyCon -> Type
1939 -- Turn the representation tycon of a family into
1940 -- a use of its family constructor
1941 mkParentType tc
1942 = case tyConFamInst_maybe tc of
1943 Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
1944 Just (fam_tc,tys) -> mkTyConApp fam_tc tys
1945
1946 {-
1947 ************************************************************************
1948 * *
1949 \subsection{Utility bits for generating bindings}
1950 * *
1951 ************************************************************************
1952 -}
1953
1954 -- | Make a function binding. If no equations are given, produce a function
1955 -- with the given arity that produces a stock error.
1956 mkFunBindSE :: Arity -> SrcSpan -> RdrName
1957 -> [([LPat GhcPs], LHsExpr GhcPs)]
1958 -> LHsBind GhcPs
1959 mkFunBindSE arity loc fun pats_and_exprs
1960 = mkRdrFunBindSE arity (L loc fun) matches
1961 where
1962 matches = [mkMatch (mkPrefixFunRhs (L loc fun))
1963 (map (parenthesizePat appPrec) p) e
1964 (noLoc emptyLocalBinds)
1965 | (p,e) <-pats_and_exprs]
1966
1967 mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
1968 -> LHsBind GhcPs
1969 mkRdrFunBind fun@(L loc _fun_rdr) matches
1970 = L loc (mkFunBind fun matches)
1971
1972 -- | Make a function binding. If no equations are given, produce a function
1973 -- with the given arity that uses an empty case expression for the last
1974 -- argument that is passes to the given function to produce the right-hand
1975 -- side.
1976 mkFunBindEC :: Arity -> SrcSpan -> RdrName
1977 -> (LHsExpr GhcPs -> LHsExpr GhcPs)
1978 -> [([LPat GhcPs], LHsExpr GhcPs)]
1979 -> LHsBind GhcPs
1980 mkFunBindEC arity loc fun catch_all pats_and_exprs
1981 = mkRdrFunBindEC arity catch_all (L loc fun) matches
1982 where
1983 matches = [ mkMatch (mkPrefixFunRhs (L loc fun))
1984 (map (parenthesizePat appPrec) p) e
1985 (noLoc emptyLocalBinds)
1986 | (p,e) <- pats_and_exprs ]
1987
1988 -- | Produces a function binding. When no equations are given, it generates
1989 -- a binding of the given arity and an empty case expression
1990 -- for the last argument that it passes to the given function to produce
1991 -- the right-hand side.
1992 mkRdrFunBindEC :: Arity
1993 -> (LHsExpr GhcPs -> LHsExpr GhcPs)
1994 -> Located RdrName
1995 -> [LMatch GhcPs (LHsExpr GhcPs)]
1996 -> LHsBind GhcPs
1997 mkRdrFunBindEC arity catch_all
1998 fun@(L loc _fun_rdr) matches = L loc (mkFunBind fun matches')
1999 where
2000 -- Catch-all eqn looks like
2001 -- fmap _ z = case z of {}
2002 -- or
2003 -- traverse _ z = pure (case z of)
2004 -- or
2005 -- foldMap _ z = mempty
2006 -- It's needed if there no data cons at all,
2007 -- which can happen with -XEmptyDataDecls
2008 -- See Trac #4302
2009 matches' = if null matches
2010 then [mkMatch (mkPrefixFunRhs fun)
2011 (replicate (arity - 1) nlWildPat ++ [z_Pat])
2012 (catch_all $ nlHsCase z_Expr [])
2013 (noLoc emptyLocalBinds)]
2014 else matches
2015
2016 -- | Produces a function binding. When there are no equations, it generates
2017 -- a binding with the given arity that produces an error based on the name of
2018 -- the type of the last argument.
2019 mkRdrFunBindSE :: Arity -> Located RdrName ->
2020 [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
2021 mkRdrFunBindSE arity
2022 fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
2023 where
2024 -- Catch-all eqn looks like
2025 -- compare _ _ = error "Void compare"
2026 -- It's needed if there no data cons at all,
2027 -- which can happen with -XEmptyDataDecls
2028 -- See Trac #4302
2029 matches' = if null matches
2030 then [mkMatch (mkPrefixFunRhs fun)
2031 (replicate arity nlWildPat)
2032 (error_Expr str) (noLoc emptyLocalBinds)]
2033 else matches
2034 str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
2035
2036
2037 box :: String -- The class involved
2038 -> TyCon -- The tycon involved
2039 -> LHsExpr GhcPs -- The argument
2040 -> Type -- The argument type
2041 -> LHsExpr GhcPs -- Boxed version of the arg
2042 -- See Note [Deriving and unboxed types] in TcDeriv
2043 box cls_str tycon arg arg_ty = nlHsApp (nlHsVar box_con) arg
2044 where
2045 box_con = assoc_ty_id cls_str tycon boxConTbl arg_ty
2046
2047 ---------------------
2048 primOrdOps :: String -- The class involved
2049 -> TyCon -- The tycon involved
2050 -> Type -- The type
2051 -> (RdrName, RdrName, RdrName, RdrName, RdrName) -- (lt,le,eq,ge,gt)
2052 -- See Note [Deriving and unboxed types] in TcDeriv
2053 primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty
2054
2055 primLitOps :: String -- The class involved
2056 -> TyCon -- The tycon involved
2057 -> Type -- The type
2058 -> ( LHsExpr GhcPs -> LHsExpr GhcPs -- Constructs a Q Exp value
2059 , LHsExpr GhcPs -> LHsExpr GhcPs -- Constructs a boxed value
2060 )
2061 primLitOps str tycon ty = ( assoc_ty_id str tycon litConTbl ty
2062 , \v -> nlHsVar boxRDR `nlHsApp` v
2063 )
2064 where
2065 boxRDR
2066 | ty `eqType` addrPrimTy = unpackCString_RDR
2067 | otherwise = assoc_ty_id str tycon boxConTbl ty
2068
2069 ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
2070 ordOpTbl
2071 = [(charPrimTy , (ltChar_RDR , leChar_RDR , eqChar_RDR , geChar_RDR , gtChar_RDR ))
2072 ,(intPrimTy , (ltInt_RDR , leInt_RDR , eqInt_RDR , geInt_RDR , gtInt_RDR ))
2073 ,(wordPrimTy , (ltWord_RDR , leWord_RDR , eqWord_RDR , geWord_RDR , gtWord_RDR ))
2074 ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR , eqAddr_RDR , geAddr_RDR , gtAddr_RDR ))
2075 ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR , eqFloat_RDR , geFloat_RDR , gtFloat_RDR ))
2076 ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR, eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ]
2077
2078 boxConTbl :: [(Type, RdrName)]
2079 boxConTbl
2080 = [(charPrimTy , getRdrName charDataCon )
2081 ,(intPrimTy , getRdrName intDataCon )
2082 ,(wordPrimTy , getRdrName wordDataCon )
2083 ,(floatPrimTy , getRdrName floatDataCon )
2084 ,(doublePrimTy, getRdrName doubleDataCon)
2085 ]
2086
2087 -- | A table of postfix modifiers for unboxed values.
2088 postfixModTbl :: [(Type, String)]
2089 postfixModTbl
2090 = [(charPrimTy , "#" )
2091 ,(intPrimTy , "#" )
2092 ,(wordPrimTy , "##")
2093 ,(floatPrimTy , "#" )
2094 ,(doublePrimTy, "##")
2095 ]
2096
2097 litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
2098 litConTbl
2099 = [(charPrimTy , nlHsApp (nlHsVar charPrimL_RDR))
2100 ,(intPrimTy , nlHsApp (nlHsVar intPrimL_RDR)
2101 . nlHsApp (nlHsVar toInteger_RDR))
2102 ,(wordPrimTy , nlHsApp (nlHsVar wordPrimL_RDR)
2103 . nlHsApp (nlHsVar toInteger_RDR))
2104 ,(addrPrimTy , nlHsApp (nlHsVar stringPrimL_RDR)
2105 . nlHsApp (nlHsApp
2106 (nlHsVar map_RDR)
2107 (compose_RDR `nlHsApps`
2108 [ nlHsVar fromIntegral_RDR
2109 , nlHsVar fromEnum_RDR
2110 ])))
2111 ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR)
2112 . nlHsApp (nlHsVar toRational_RDR))
2113 ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR)
2114 . nlHsApp (nlHsVar toRational_RDR))
2115 ]
2116
2117 -- | Lookup `Type` in an association list.
2118 assoc_ty_id :: String -- The class involved
2119 -> TyCon -- The tycon involved
2120 -> [(Type,a)] -- The table
2121 -> Type -- The type
2122 -> a -- The result of the lookup
2123 assoc_ty_id cls_str _ tbl ty
2124 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
2125 text "for primitive type" <+> ppr ty)
2126 | otherwise = head res
2127 where
2128 res = [id | (ty',id) <- tbl, ty `eqType` ty']
2129
2130 -----------------------------------------------------------------------
2131
2132 and_Expr :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
2133 and_Expr a b = genOpApp a and_RDR b
2134
2135 -----------------------------------------------------------------------
2136
2137 eq_Expr :: TyCon -> Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
2138 eq_Expr tycon ty a b
2139 | not (isUnliftedType ty) = genOpApp a eq_RDR b
2140 | otherwise = genPrimOpApp a prim_eq b
2141 where
2142 (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
2143
2144 untag_Expr :: DynFlags -> TyCon -> [( RdrName, RdrName)]
2145 -> LHsExpr GhcPs -> LHsExpr GhcPs
2146 untag_Expr _ _ [] expr = expr
2147 untag_Expr dflags tycon ((untag_this, put_tag_here) : more) expr
2148 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR dflags tycon)
2149 [untag_this])) {-of-}
2150 [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr dflags tycon more expr)]
2151
2152 enum_from_to_Expr
2153 :: LHsExpr GhcPs -> LHsExpr GhcPs
2154 -> LHsExpr GhcPs
2155 enum_from_then_to_Expr
2156 :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
2157 -> LHsExpr GhcPs
2158
2159 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
2160 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
2161
2162 showParen_Expr
2163 :: LHsExpr GhcPs -> LHsExpr GhcPs
2164 -> LHsExpr GhcPs
2165
2166 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
2167
2168 nested_compose_Expr :: [LHsExpr GhcPs] -> LHsExpr GhcPs
2169
2170 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
2171 nested_compose_Expr [e] = parenify e
2172 nested_compose_Expr (e:es)
2173 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
2174
2175 -- impossible_Expr is used in case RHSs that should never happen.
2176 -- We generate these to keep the desugarer from complaining that they *might* happen!
2177 error_Expr :: String -> LHsExpr GhcPs
2178 error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
2179
2180 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
2181 -- method. It is currently only used by Enum.{succ,pred}
2182 illegal_Expr :: String -> String -> String -> LHsExpr GhcPs
2183 illegal_Expr meth tp msg =
2184 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
2185
2186 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
2187 -- to include the value of a_RDR in the error string.
2188 illegal_toEnum_tag :: String -> RdrName -> LHsExpr GhcPs
2189 illegal_toEnum_tag tp maxtag =
2190 nlHsApp (nlHsVar error_RDR)
2191 (nlHsApp (nlHsApp (nlHsVar append_RDR)
2192 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
2193 (nlHsApp (nlHsApp (nlHsApp
2194 (nlHsVar showsPrec_RDR)
2195 (nlHsIntLit 0))
2196 (nlHsVar a_RDR))
2197 (nlHsApp (nlHsApp
2198 (nlHsVar append_RDR)
2199 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
2200 (nlHsApp (nlHsApp (nlHsApp
2201 (nlHsVar showsPrec_RDR)
2202 (nlHsIntLit 0))
2203 (nlHsVar maxtag))
2204 (nlHsLit (mkHsString ")"))))))
2205
2206 parenify :: LHsExpr GhcPs -> LHsExpr GhcPs
2207 parenify e@(L _ (HsVar _ _)) = e
2208 parenify e = mkHsPar e
2209
2210 -- genOpApp wraps brackets round the operator application, so that the
2211 -- renamer won't subsequently try to re-associate it.
2212 genOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
2213 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
2214
2215 genPrimOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
2216 genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2))
2217
2218 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
2219 :: RdrName
2220 a_RDR = mkVarUnqual (fsLit "a")
2221 b_RDR = mkVarUnqual (fsLit "b")
2222 c_RDR = mkVarUnqual (fsLit "c")
2223 d_RDR = mkVarUnqual (fsLit "d")
2224 f_RDR = mkVarUnqual (fsLit "f")
2225 k_RDR = mkVarUnqual (fsLit "k")
2226 z_RDR = mkVarUnqual (fsLit "z")
2227 ah_RDR = mkVarUnqual (fsLit "a#")
2228 bh_RDR = mkVarUnqual (fsLit "b#")
2229 ch_RDR = mkVarUnqual (fsLit "c#")
2230 dh_RDR = mkVarUnqual (fsLit "d#")
2231
2232 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
2233 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
2234 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
2235 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
2236
2237 a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr,
2238 true_Expr, pure_Expr :: LHsExpr GhcPs
2239 a_Expr = nlHsVar a_RDR
2240 b_Expr = nlHsVar b_RDR
2241 c_Expr = nlHsVar c_RDR
2242 z_Expr = nlHsVar z_RDR
2243 ltTag_Expr = nlHsVar ltTag_RDR
2244 eqTag_Expr = nlHsVar eqTag_RDR
2245 gtTag_Expr = nlHsVar gtTag_RDR
2246 false_Expr = nlHsVar false_RDR
2247 true_Expr = nlHsVar true_RDR
2248 pure_Expr = nlHsVar pure_RDR
2249
2250 a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat GhcPs
2251 a_Pat = nlVarPat a_RDR
2252 b_Pat = nlVarPat b_RDR
2253 c_Pat = nlVarPat c_RDR
2254 d_Pat = nlVarPat d_RDR
2255 k_Pat = nlVarPat k_RDR
2256 z_Pat = nlVarPat z_RDR
2257
2258 minusInt_RDR, tagToEnum_RDR :: RdrName
2259 minusInt_RDR = getRdrName (primOpId IntSubOp )
2260 tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)
2261
2262 con2tag_RDR, tag2con_RDR, maxtag_RDR :: DynFlags -> TyCon -> RdrName
2263 -- Generates Orig s RdrName, for the binding positions
2264 con2tag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkCon2TagOcc
2265 tag2con_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkTag2ConOcc
2266 maxtag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkMaxTagOcc
2267
2268 mk_tc_deriv_name :: DynFlags -> TyCon -> (OccName -> OccName) -> RdrName
2269 mk_tc_deriv_name dflags tycon occ_fun =
2270 mkAuxBinderName dflags (tyConName tycon) occ_fun
2271
2272 mkAuxBinderName :: DynFlags -> Name -> (OccName -> OccName) -> RdrName
2273 -- ^ Make a top-level binder name for an auxiliary binding for a parent name
2274 -- See Note [Auxiliary binders]
2275 mkAuxBinderName dflags parent occ_fun
2276 = mkRdrUnqual (occ_fun stable_parent_occ)
2277 where
2278 stable_parent_occ = mkOccName (occNameSpace parent_occ) stable_string
2279 stable_string
2280 | hasPprDebug dflags = parent_stable
2281 | otherwise = parent_stable_hash
2282 parent_stable = nameStableString parent
2283 parent_stable_hash =
2284 let Fingerprint high low = fingerprintString parent_stable
2285 in toBase62 high ++ toBase62Padded low
2286 -- See Note [Base 62 encoding 128-bit integers] in Encoding
2287 parent_occ = nameOccName parent
2288
2289
2290 {-
2291 Note [Auxiliary binders]
2292 ~~~~~~~~~~~~~~~~~~~~~~~~
2293 We often want to make a top-level auxiliary binding. E.g. for comparison we haev
2294
2295 instance Ord T where
2296 compare a b = $con2tag a `compare` $con2tag b
2297
2298 $con2tag :: T -> Int
2299 $con2tag = ...code....
2300
2301 Of course these top-level bindings should all have distinct name, and we are
2302 generating RdrNames here. We can't just use the TyCon or DataCon to distinguish
2303 because with standalone deriving two imported TyCons might both be called T!
2304 (See Trac #7947.)
2305
2306 So we use package name, module name and the name of the parent
2307 (T in this example) as part of the OccName we generate for the new binding.
2308 To make the symbol names short we take a base62 hash of the full name.
2309
2310 In the past we used the *unique* from the parent, but that's not stable across
2311 recompilations as uniques are nondeterministic.
2312 -}