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