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