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