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