2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 TcGenDeriv: Generating derived instance declarations
8 This module is nominally ``subordinate'' to @TcDeriv@, which is the
9 ``official'' interface to deriving-related things.
11 This is where we do all the grimy bindings' generation.
15 DerivAuxBinds, isDupAux,
26 gen_Functor_binds, functorLikeTraverse, deepSubtypesContaining,
28 gen_Traversable_binds,
32 #include "HsVersions.h"
61 import Data.List ( partition, intersperse )
65 type DerivAuxBinds = [DerivAuxBind]
67 data DerivAuxBind -- Please add these auxiliary top-level bindings
68 = GenCon2Tag TyCon -- The con2Tag for given TyCon
69 | GenTag2Con TyCon -- ...ditto tag2Con
70 | GenMaxTag TyCon -- ...and maxTag
72 -- Scrap your boilerplate
73 | MkDataCon DataCon -- For constructor C we get $cC :: Constr
74 | MkTyCon TyCon -- For tycon T we get $tT :: DataType
77 isDupAux :: DerivAuxBind -> DerivAuxBind -> Bool
78 isDupAux (GenCon2Tag tc1) (GenCon2Tag tc2) = tc1 == tc2
79 isDupAux (GenTag2Con tc1) (GenTag2Con tc2) = tc1 == tc2
80 isDupAux (GenMaxTag tc1) (GenMaxTag tc2) = tc1 == tc2
81 isDupAux (MkDataCon dc1) (MkDataCon dc2) = dc1 == dc2
82 isDupAux (MkTyCon tc1) (MkTyCon tc2) = tc1 == tc2
87 %************************************************************************
91 %************************************************************************
93 Here are the heuristics for the code we generate for @Eq@:
96 Let's assume we have a data type with some (possibly zero) nullary
97 data constructors and some ordinary, non-nullary ones (the rest,
98 also possibly zero of them). Here's an example, with both \tr{N}ullary
99 and \tr{O}rdinary data cons.
101 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
105 For the ordinary constructors (if any), we emit clauses to do The
109 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
110 (==) (O2 a1) (O2 a2) = a1 == a2
111 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
114 Note: if we're comparing unlifted things, e.g., if \tr{a1} and
115 \tr{a2} are \tr{Float#}s, then we have to generate
117 case (a1 `eqFloat#` a2) of
120 for that particular test.
123 If there are any nullary constructors, we emit a catch-all clause of
127 (==) a b = case (con2tag_Foo a) of { a# ->
128 case (con2tag_Foo b) of { b# ->
129 case (a# ==# b#) of {
134 If there aren't any nullary constructors, we emit a simpler
141 For the @(/=)@ method, we normally just use the default method.
143 If the type is an enumeration type, we could/may/should? generate
144 special code that calls @con2tag_Foo@, much like for @(==)@ shown
148 We thought about doing this: If we're also deriving @Ord@ for this
151 instance ... Eq (Foo ...) where
152 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
153 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
155 However, that requires that \tr{Ord <whatever>} was put in the context
156 for the instance decl, which it probably wasn't, so the decls
157 produced don't get through the typechecker.
162 gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
163 gen_Eq_binds loc tycon
164 = (method_binds, aux_binds)
166 (nullary_cons, nonnullary_cons)
167 | isNewTyCon tycon = ([], tyConDataCons tycon)
168 | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon)
170 no_nullary_cons = null nullary_cons
172 rest | no_nullary_cons
173 = case tyConSingleDataCon_maybe tycon of
175 Nothing -> -- if cons don't match, then False
176 [([nlWildPat, nlWildPat], false_Expr)]
177 | otherwise -- calc. and compare the tags
179 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
180 (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
182 aux_binds | no_nullary_cons = []
183 | otherwise = [GenCon2Tag tycon]
185 method_binds = listToBag [
186 mk_FunBind loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest),
187 mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
188 nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))]
190 ------------------------------------------------------------------
193 con1_pat = nlConVarPat data_con_RDR as_needed
194 con2_pat = nlConVarPat data_con_RDR bs_needed
196 data_con_RDR = getRdrName data_con
197 con_arity = length tys_needed
198 as_needed = take con_arity as_RDRs
199 bs_needed = take con_arity bs_RDRs
200 tys_needed = dataConOrigArgTys data_con
202 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
204 nested_eq_expr [] [] [] = true_Expr
205 nested_eq_expr tys as bs
206 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
208 nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
211 %************************************************************************
215 %************************************************************************
217 For a derived @Ord@, we concentrate our attentions on @compare@
219 compare :: a -> a -> Ordering
220 data Ordering = LT | EQ | GT deriving ()
223 We will use the same example data type as above:
225 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
230 We do all the other @Ord@ methods with calls to @compare@:
232 instance ... (Ord <wurble> <wurble>) where
233 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
234 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
235 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
236 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
238 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
239 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
241 -- compare to come...
245 @compare@ always has two parts. First, we use the compared
246 data-constructors' tags to deal with the case of different
249 compare a b = case (con2tag_Foo a) of { a# ->
250 case (con2tag_Foo b) of { b# ->
251 case (a# ==# b#) of {
253 False -> case (a# <# b#) of
258 cmp_eq = ... to come ...
262 We are only left with the ``help'' function @cmp_eq@, to deal with
263 comparing data constructors with the same tag.
265 For the ordinary constructors (if any), we emit the sorta-obvious
266 compare-style stuff; for our example:
268 cmp_eq (O1 a1 b1) (O1 a2 b2)
269 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
271 cmp_eq (O2 a1) (O2 a2)
274 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
275 = case (compare a1 a2) of {
278 EQ -> case compare b1 b2 of {
286 Again, we must be careful about unlifted comparisons. For example,
287 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
291 cmp_eq lt eq gt (O2 a1) (O2 a2)
293 -- or maybe the unfolded equivalent
297 For the remaining nullary constructors, we already know that the
304 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
308 gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
310 gen_Ord_binds loc tycon
311 | Just (con, prim_tc) <- primWrapperType_maybe tycon
312 = gen_PrimOrd_binds con prim_tc
315 = (unitBag compare, aux_binds)
316 -- `AndMonoBinds` compare
317 -- The default declaration in PrelBase handles this
319 aux_binds | single_con_type = []
320 | otherwise = [GenCon2Tag tycon]
322 compare = L loc (mkFunBind (L loc compare_RDR) compare_matches)
323 compare_matches = [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds]
324 cmp_eq_binds = HsValBinds (ValBindsIn (unitBag cmp_eq) [])
327 | single_con_type = cmp_eq_Expr a_Expr b_Expr
329 = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
330 (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR
331 (cmp_eq_Expr a_Expr b_Expr) -- True case
332 -- False case; they aren't equal
333 -- So we need to do a less-than comparison on the tags
334 (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))
336 tycon_data_cons = tyConDataCons tycon
337 single_con_type = isSingleton tycon_data_cons
338 (nullary_cons, nonnullary_cons)
339 | isNewTyCon tycon = ([], tyConDataCons tycon)
340 | otherwise = partition isNullarySrcDataCon tycon_data_cons
342 cmp_eq = mk_FunBind loc cmp_eq_RDR cmp_eq_match
344 | isEnumerationTyCon tycon
345 -- We know the tags are equal, so if it's an enumeration TyCon,
346 -- then there is nothing left to do
347 -- Catch this specially to avoid warnings
348 -- about overlapping patterns from the desugarer,
349 -- and to avoid unnecessary pattern-matching
350 = [([nlWildPat,nlWildPat], eqTag_Expr)]
352 = map pats_etc nonnullary_cons ++
353 (if single_con_type then -- Omit wildcards when there's just one
354 [] -- constructor, to silence desugarer
356 [([nlWildPat, nlWildPat], default_rhs)])
358 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
359 -- inexhaustive patterns
360 | otherwise = eqTag_Expr -- Some nullary constructors;
361 -- Tags are equal, no args => return EQ
363 = ([con1_pat, con2_pat],
364 nested_compare_expr tys_needed as_needed bs_needed)
366 con1_pat = nlConVarPat data_con_RDR as_needed
367 con2_pat = nlConVarPat data_con_RDR bs_needed
369 data_con_RDR = getRdrName data_con
370 con_arity = length tys_needed
371 as_needed = take con_arity as_RDRs
372 bs_needed = take con_arity bs_RDRs
373 tys_needed = dataConOrigArgTys data_con
375 nested_compare_expr [ty] [a] [b]
376 = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b)
378 nested_compare_expr (ty:tys) (a:as) (b:bs)
379 = let eq_expr = nested_compare_expr tys as bs
380 in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b)
382 nested_compare_expr _ _ _ = panic "nested_compare_expr" -- Args always equal length
385 Note [Comparision of primitive types]
386 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
387 The general plan does not work well for data types like
388 data T = MkT Int# deriving( Ord )
389 The general plan defines the 'compare' method, gets (<) etc from it. But
390 that means we get silly code like:
392 (>) (I# x) (I# y) = case <# x y of
394 False -> case ==# x y of
397 We would prefer to use the (>#) primop. See also Trac #2130
401 gen_PrimOrd_binds :: DataCon -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
402 -- See Note [Comparison of primitive types]
403 gen_PrimOrd_binds data_con prim_tc
404 = (listToBag [mk_op lt_RDR lt_op, mk_op le_RDR le_op,
405 mk_op ge_RDR ge_op, mk_op gt_RDR gt_op], [])
407 mk_op op_RDR op = mk_FunBind (getSrcSpan data_con) op_RDR
408 [([apat, bpat], genOpApp a_Expr (primOpRdrName op) b_Expr)]
409 con_RDR = getRdrName data_con
410 apat = nlConVarPat con_RDR [a_RDR]
411 bpat = nlConVarPat con_RDR [b_RDR]
413 (lt_op, le_op, ge_op, gt_op)
414 | prim_tc == charPrimTyCon = (CharLtOp, CharLeOp, CharGeOp, CharGtOp)
415 | prim_tc == intPrimTyCon = (IntLtOp, IntLeOp, IntGeOp, IntGtOp)
416 | prim_tc == wordPrimTyCon = (WordLtOp, WordLeOp, WordGeOp, WordGtOp)
417 | prim_tc == addrPrimTyCon = (AddrLtOp, AddrLeOp, AddrGeOp, AddrGtOp)
418 | prim_tc == floatPrimTyCon = (FloatLtOp, FloatLeOp, FloatGeOp, FloatGtOp)
419 | prim_tc == doublePrimTyCon = (DoubleLtOp, DoubleLeOp, DoubleGeOp, DoubleGtOp)
420 | otherwise = pprPanic "Unexpected primitive tycon" (ppr prim_tc)
423 primWrapperType_maybe :: TyCon -> Maybe (DataCon, TyCon)
424 -- True of data types that are wrappers around prmitive types
425 -- data T = MkT Word#
426 -- For these we want to generate all the (<), (<=) etc operations individually
427 primWrapperType_maybe tc
428 | [con] <- tyConDataCons tc
429 , [ty] <- dataConOrigArgTys con
430 , Just (prim_tc, []) <- tcSplitTyConApp_maybe ty
431 , isPrimTyCon prim_tc
432 = Just (con, prim_tc)
437 %************************************************************************
441 %************************************************************************
443 @Enum@ can only be derived for enumeration types. For a type
445 data Foo ... = N1 | N2 | ... | Nn
448 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
449 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
452 instance ... Enum (Foo ...) where
453 succ x = toEnum (1 + fromEnum x)
454 pred x = toEnum (fromEnum x - 1)
456 toEnum i = tag2con_Foo i
458 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
462 = case con2tag_Foo a of
463 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
466 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
470 = case con2tag_Foo a of { a# ->
471 case con2tag_Foo b of { b# ->
472 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
476 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
479 gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
480 gen_Enum_binds loc tycon
481 = (method_binds, aux_binds)
483 method_binds = listToBag [
491 aux_binds = [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon]
493 occ_nm = getOccString tycon
496 = mk_easy_FunBind loc succ_RDR [a_Pat] $
497 untag_Expr tycon [(a_RDR, ah_RDR)] $
498 nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
499 nlHsVarApps intDataCon_RDR [ah_RDR]])
500 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
501 (nlHsApp (nlHsVar (tag2con_RDR tycon))
502 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
506 = mk_easy_FunBind loc pred_RDR [a_Pat] $
507 untag_Expr tycon [(a_RDR, ah_RDR)] $
508 nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
509 nlHsVarApps intDataCon_RDR [ah_RDR]])
510 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
511 (nlHsApp (nlHsVar (tag2con_RDR tycon))
512 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
513 nlHsLit (HsInt (-1))]))
516 = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
517 nlHsIf (nlHsApps and_RDR
518 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
519 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
520 (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
521 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
524 = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
525 untag_Expr tycon [(a_RDR, ah_RDR)] $
527 [nlHsVar (tag2con_RDR tycon),
528 nlHsPar (enum_from_to_Expr
529 (nlHsVarApps intDataCon_RDR [ah_RDR])
530 (nlHsVar (maxtag_RDR tycon)))]
533 = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
534 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
535 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
536 nlHsPar (enum_from_then_to_Expr
537 (nlHsVarApps intDataCon_RDR [ah_RDR])
538 (nlHsVarApps intDataCon_RDR [bh_RDR])
539 (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
540 nlHsVarApps intDataCon_RDR [bh_RDR]])
542 (nlHsVar (maxtag_RDR tycon))
546 = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
547 untag_Expr tycon [(a_RDR, ah_RDR)] $
548 (nlHsVarApps intDataCon_RDR [ah_RDR])
551 %************************************************************************
555 %************************************************************************
558 gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
559 gen_Bounded_binds loc tycon
560 | isEnumerationTyCon tycon
561 = (listToBag [ min_bound_enum, max_bound_enum ], [])
563 = ASSERT(isSingleton data_cons)
564 (listToBag [ min_bound_1con, max_bound_1con ], [])
566 data_cons = tyConDataCons tycon
568 ----- enum-flavored: ---------------------------
569 min_bound_enum = mkVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
570 max_bound_enum = mkVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
572 data_con_1 = head data_cons
573 data_con_N = last data_cons
574 data_con_1_RDR = getRdrName data_con_1
575 data_con_N_RDR = getRdrName data_con_N
577 ----- single-constructor-flavored: -------------
578 arity = dataConSourceArity data_con_1
580 min_bound_1con = mkVarBind loc minBound_RDR $
581 nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
582 max_bound_1con = mkVarBind loc maxBound_RDR $
583 nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
586 %************************************************************************
590 %************************************************************************
592 Deriving @Ix@ is only possible for enumeration types and
593 single-constructor types. We deal with them in turn.
595 For an enumeration type, e.g.,
597 data Foo ... = N1 | N2 | ... | Nn
599 things go not too differently from @Enum@:
601 instance ... Ix (Foo ...) where
603 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
607 = case (con2tag_Foo a) of { a# ->
608 case (con2tag_Foo b) of { b# ->
609 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
612 -- Generate code for unsafeIndex, becuase using index leads
613 -- to lots of redundant range tests
614 unsafeIndex c@(a, b) d
615 = case (con2tag_Foo d -# con2tag_Foo a) of
620 p_tag = con2tag_Foo c
622 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
626 = case (con2tag_Foo a) of { a_tag ->
627 case (con2tag_Foo b) of { b_tag ->
628 case (con2tag_Foo c) of { c_tag ->
629 if (c_tag >=# a_tag) then
635 (modulo suitable case-ification to handle the unlifted tags)
637 For a single-constructor type (NB: this includes all tuples), e.g.,
639 data Foo ... = MkFoo a b Int Double c c
641 we follow the scheme given in Figure~19 of the Haskell~1.2 report
645 gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
647 gen_Ix_binds loc tycon
648 | isEnumerationTyCon tycon
649 = (enum_ixes, [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon])
651 = (single_con_ixes, [GenCon2Tag tycon])
653 --------------------------------------------------------------
654 enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
657 = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
658 untag_Expr tycon [(a_RDR, ah_RDR)] $
659 untag_Expr tycon [(b_RDR, bh_RDR)] $
660 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
661 nlHsPar (enum_from_to_Expr
662 (nlHsVarApps intDataCon_RDR [ah_RDR])
663 (nlHsVarApps intDataCon_RDR [bh_RDR]))
666 = mk_easy_FunBind loc unsafeIndex_RDR
667 [noLoc (AsPat (noLoc c_RDR)
668 (nlTuplePat [a_Pat, nlWildPat] Boxed)),
670 untag_Expr tycon [(a_RDR, ah_RDR)] (
671 untag_Expr tycon [(d_RDR, dh_RDR)] (
673 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
676 (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
677 [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
682 = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
683 untag_Expr tycon [(a_RDR, ah_RDR)] (
684 untag_Expr tycon [(b_RDR, bh_RDR)] (
685 untag_Expr tycon [(c_RDR, ch_RDR)] (
686 nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
687 (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
692 --------------------------------------------------------------
694 = listToBag [single_con_range, single_con_index, single_con_inRange]
697 = case tyConSingleDataCon_maybe tycon of -- just checking...
698 Nothing -> panic "get_Ix_binds"
701 con_arity = dataConSourceArity data_con
702 data_con_RDR = getRdrName data_con
704 as_needed = take con_arity as_RDRs
705 bs_needed = take con_arity bs_RDRs
706 cs_needed = take con_arity cs_RDRs
708 con_pat xs = nlConVarPat data_con_RDR xs
709 con_expr = nlHsVarApps data_con_RDR cs_needed
711 --------------------------------------------------------------
713 = mk_easy_FunBind loc range_RDR
714 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
715 nlHsDo ListComp stmts con_expr
717 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
719 mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
720 (nlHsApp (nlHsVar range_RDR)
721 (nlTuple [nlHsVar a, nlHsVar b] Boxed))
725 = mk_easy_FunBind loc unsafeIndex_RDR
726 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
728 -- We need to reverse the order we consider the components in
730 -- range (l,u) !! index (l,u) i == i -- when i is in range
731 -- (from http://haskell.org/onlinereport/ix.html) holds.
732 (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
734 -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
735 mk_index [] = nlHsIntLit 0
736 mk_index [(l,u,i)] = mk_one l u i
737 mk_index ((l,u,i) : rest)
742 (nlHsApp (nlHsVar unsafeRangeSize_RDR)
743 (nlTuple [nlHsVar l, nlHsVar u] Boxed))
744 ) times_RDR (mk_index rest)
747 = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i]
751 = mk_easy_FunBind loc inRange_RDR
752 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
754 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
756 in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
760 %************************************************************************
764 %************************************************************************
774 instance Read T where
778 do x <- ReadP.step Read.readPrec
779 Symbol "%%" <- Lex.lex
780 y <- ReadP.step Read.readPrec
784 -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
785 -- Record construction binds even more tightly than application
786 do Ident "T1" <- Lex.lex
788 Ident "f1" <- Lex.lex
790 x <- ReadP.reset Read.readPrec
792 return (T1 { f1 = x }))
795 do Ident "T2" <- Lex.lexP
796 x <- ReadP.step Read.readPrec
800 readListPrec = readListPrecDefault
801 readList = readListDefault
805 gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
807 gen_Read_binds get_fixity loc tycon
808 = (listToBag [read_prec, default_readlist, default_readlistprec], [])
810 -----------------------------------------------------------------------
812 = mkVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
815 = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
816 -----------------------------------------------------------------------
818 data_cons = tyConDataCons tycon
819 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
821 read_prec = mkVarBind loc readPrec_RDR
822 (nlHsApp (nlHsVar parens_RDR) read_cons)
824 read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
825 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
828 = case nullary_cons of
830 [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
831 (result_expr con [])]
832 _ -> [nlHsApp (nlHsVar choose_RDR)
833 (nlList (map mk_pair nullary_cons))]
835 mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)),
839 read_non_nullary_con data_con
840 | is_infix = mk_parser infix_prec infix_stmts body
841 | is_record = mk_parser record_prec record_stmts body
842 -- Using these two lines instead allows the derived
843 -- read for infix and record bindings to read the prefix form
844 -- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body)
845 -- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
846 | otherwise = prefix_parser
848 body = result_expr data_con as_needed
849 con_str = data_con_str data_con
851 prefix_parser = mk_parser prefix_prec prefix_stmts body
854 | isSym con_str = [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"]
855 | otherwise = [bindLex (ident_pat con_str)]
858 | isSym con_str = [bindLex (symbol_pat con_str)]
859 | otherwise = [read_punc "`", bindLex (ident_pat con_str), read_punc "`"]
861 prefix_stmts -- T a b c
862 = read_prefix_con ++ read_args
864 infix_stmts -- a %% b, or a `T` b
869 record_stmts -- T { f1 = a, f2 = b }
872 ++ concat (intersperse [read_punc ","] field_stmts)
875 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
877 con_arity = dataConSourceArity data_con
878 labels = dataConFieldLabels data_con
879 dc_nm = getName data_con
880 is_infix = dataConIsInfix data_con
881 is_record = length labels > 0
882 as_needed = take con_arity as_RDRs
883 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
884 (read_a1:read_a2:_) = read_args
886 prefix_prec = appPrecedence
887 infix_prec = getPrecedence get_fixity dc_nm
888 record_prec = appPrecedence + 1 -- Record construction binds even more tightly
889 -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
891 ------------------------------------------------------------------------
893 ------------------------------------------------------------------------
894 mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
895 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b] -- prec p (do { ss ; b })
896 bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP
897 con_app con as = nlHsVarApps (getRdrName con) as -- con as
898 result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
900 punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
901 ident_pat s = nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo"
902 symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>"
904 data_con_str con = occNameString (getOccName con)
906 read_punc c = bindLex (punc_pat c)
907 read_arg a ty = ASSERT( not (isUnLiftedType ty) )
908 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
910 read_field lbl a = read_lbl lbl ++
912 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
914 -- When reading field labels we might encounter
919 read_lbl lbl | isSym lbl_str
921 bindLex (symbol_pat lbl_str),
924 = [bindLex (ident_pat lbl_str)]
926 lbl_str = occNameString (getOccName lbl)
930 %************************************************************************
934 %************************************************************************
940 data Tree a = Leaf a | Tree a :^: Tree a
942 instance (Show a) => Show (Tree a) where
944 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
946 showStr = showString "Leaf " . showsPrec (app_prec+1) m
948 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
950 showStr = showsPrec (up_prec+1) u .
952 showsPrec (up_prec+1) v
953 -- Note: right-associativity of :^: ignored
955 up_prec = 5 -- Precedence of :^:
956 app_prec = 10 -- Application has precedence one more than
957 -- the most tightly-binding operator
960 gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
962 gen_Show_binds get_fixity loc tycon
963 = (listToBag [shows_prec, show_list], [])
965 -----------------------------------------------------------------------
966 show_list = mkVarBind loc showList_RDR
967 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
968 -----------------------------------------------------------------------
969 shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
972 | nullary_con = -- skip the showParen junk...
973 ASSERT(null bs_needed)
974 ([nlWildPat, con_pat], mk_showString_app con_str)
977 showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
978 (nlHsPar (nested_compose_Expr show_thingies)))
980 data_con_RDR = getRdrName data_con
981 con_arity = dataConSourceArity data_con
982 bs_needed = take con_arity bs_RDRs
983 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
984 con_pat = nlConVarPat data_con_RDR bs_needed
985 nullary_con = con_arity == 0
986 labels = dataConFieldLabels data_con
987 lab_fields = length labels
988 record_syntax = lab_fields > 0
990 dc_nm = getName data_con
991 dc_occ_nm = getOccName data_con
992 con_str = occNameString dc_occ_nm
993 op_con_str = wrapOpParens con_str
994 backquote_str = wrapOpBackquotes con_str
997 | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
998 | record_syntax = mk_showString_app (op_con_str ++ " {") :
999 show_record_args ++ [mk_showString_app "}"]
1000 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
1002 show_label l = mk_showString_app (nm ++ " = ")
1003 -- Note the spaces around the "=" sign. If we don't have them
1004 -- then we get Foo { x=-1 } and the "=-" parses as a single
1005 -- lexeme. Only the space after the '=' is necessary, but
1006 -- it seems tidier to have them both sides.
1008 occ_nm = getOccName l
1009 nm = wrapOpParens (occNameString occ_nm)
1011 show_args = zipWith show_arg bs_needed arg_tys
1012 (show_arg1:show_arg2:_) = show_args
1013 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
1015 -- Assumption for record syntax: no of fields == no of labelled fields
1016 -- (and in same order)
1017 show_record_args = concat $
1018 intersperse [mk_showString_app ", "] $
1019 [ [show_label lbl, arg]
1020 | (lbl,arg) <- zipEqual "gen_Show_binds"
1023 -- Generates (showsPrec p x) for argument x, but it also boxes
1024 -- the argument first if necessary. Note that this prints unboxed
1025 -- things without any '#' decorations; could change that if need be
1026 show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
1027 box_if_necy "Show" tycon (nlHsVar b) arg_ty]
1030 is_infix = dataConIsInfix data_con
1031 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1032 arg_prec | record_syntax = 0 -- Record fields don't need parens
1033 | otherwise = con_prec_plus_one
1035 wrapOpParens :: String -> String
1036 wrapOpParens s | isSym s = '(' : s ++ ")"
1039 wrapOpBackquotes :: String -> String
1040 wrapOpBackquotes s | isSym s = s
1041 | otherwise = '`' : s ++ "`"
1043 isSym :: String -> Bool
1045 isSym (c : _) = startsVarSym c || startsConSym c
1047 mk_showString_app :: String -> LHsExpr RdrName
1048 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1052 getPrec :: Bool -> FixityEnv -> Name -> Integer
1053 getPrec is_infix get_fixity nm
1054 | not is_infix = appPrecedence
1055 | otherwise = getPrecedence get_fixity nm
1057 appPrecedence :: Integer
1058 appPrecedence = fromIntegral maxPrecedence + 1
1059 -- One more than the precedence of the most
1060 -- tightly-binding operator
1062 getPrecedence :: FixityEnv -> Name -> Integer
1063 getPrecedence get_fixity nm
1064 = case lookupFixity get_fixity nm of
1065 Fixity x _assoc -> fromIntegral x
1066 -- NB: the Report says that associativity is not taken
1067 -- into account for either Read or Show; hence we
1068 -- ignore associativity here
1072 %************************************************************************
1074 \subsection{Typeable}
1076 %************************************************************************
1084 instance Typeable2 T where
1085 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1087 We are passed the Typeable2 class as well as T
1090 gen_Typeable_binds :: SrcSpan -> TyCon -> LHsBinds RdrName
1091 gen_Typeable_binds loc tycon
1094 (mk_typeOf_RDR tycon) -- Name of appropriate type0f function
1096 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1098 tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1100 mk_typeOf_RDR :: TyCon -> RdrName
1101 -- Use the arity of the TyCon to make the right typeOfn function
1102 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1104 arity = tyConArity tycon
1105 suffix | arity == 0 = ""
1106 | otherwise = show arity
1111 %************************************************************************
1115 %************************************************************************
1119 data T a b = T1 a b | T2
1123 $cT1 = mkDataCon $dT "T1" Prefix
1124 $cT2 = mkDataCon $dT "T2" Prefix
1125 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1126 -- the [] is for field labels.
1128 instance (Data a, Data b) => Data (T a b) where
1129 gfoldl k z (T1 a b) = z T `k` a `k` b
1130 gfoldl k z T2 = z T2
1131 -- ToDo: add gmapT,Q,M, gfoldr
1133 gunfold k z c = case conIndex c of
1134 I# 1# -> k (k (z T1))
1137 toConstr (T1 _ _) = $cT1
1143 gen_Data_binds :: SrcSpan
1145 -> (LHsBinds RdrName, -- The method bindings
1146 DerivAuxBinds) -- Auxiliary bindings
1147 gen_Data_binds loc tycon
1148 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
1149 -- Auxiliary definitions: the data type and constructors
1150 MkTyCon tycon : map MkDataCon data_cons)
1152 data_cons = tyConDataCons tycon
1153 n_cons = length data_cons
1154 one_constr = n_cons == 1
1157 gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons)
1158 gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1159 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1162 con_name = getRdrName con
1163 as_needed = take (dataConSourceArity con) as_RDRs
1164 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1166 ------------ gunfold
1167 gunfold_bind = mk_FunBind loc
1169 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1173 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1174 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1175 (map gunfold_alt data_cons)
1177 gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1178 mk_unfold_rhs dc = foldr nlHsApp
1179 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1180 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1182 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1183 -- redundant test, and annoying warning
1184 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1185 | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1189 ------------ toConstr
1190 toCon_bind = mk_FunBind loc toConstr_RDR (map to_con_eqn data_cons)
1191 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1193 ------------ dataTypeOf
1194 dataTypeOf_bind = mk_easy_FunBind
1198 (nlHsVar (mk_data_type_name tycon))
1201 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
1202 mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR :: RdrName
1203 gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
1204 gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
1205 toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
1206 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1207 mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
1208 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1209 conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
1210 prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix")
1211 infix_RDR = dataQual_RDR gENERICS (fsLit "Infix")
1216 %************************************************************************
1220 %************************************************************************
1224 data T a = T1 Int a | T2 (T a)
1226 We generate the instance:
1228 instance Functor T where
1229 fmap f (T1 b1 a) = T1 b1 (f a)
1230 fmap f (T2 ta) = T2 (fmap f ta)
1232 Notice that we don't simply apply 'fmap' to the constructor arguments.
1234 - Do nothing to an argument whose type doesn't mention 'a'
1235 - Apply 'f' to an argument of type 'a'
1236 - Apply 'fmap f' to other arguments
1237 That's why we have to recurse deeply into the constructor argument types,
1238 rather than just one level, as we typically do.
1240 What about types with more than one type parameter? In general, we only
1241 derive Functor for the last position:
1243 data S a b = S1 [b] | S2 a
1244 instance Functor (S a) where
1245 fmap f (S1 bs) = S1 (fmap f bs)
1246 fmap f (S2 a) = S2 a
1248 However, we have special cases for
1252 More formally, we write the derivation of fmap code over type variable
1253 'a for type 'b as ($fmap 'a 'b). In this general notation the derived
1256 instance Functor T where
1257 fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
1258 fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1)
1260 $(fmap 'a 'b) x = x -- when b does not contain a
1261 $(fmap 'a 'a) x = f x
1262 $(fmap 'a '(b1,b2)) x = case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
1263 $(fmap 'a '(T b1 b2)) x = fmap $(fmap 'a 'b2) x -- when a only occurs in the last parameter, b2
1264 $(fmap 'a '(b -> c)) x = \b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
1266 For functions, the type parameter 'a can occur in a contravariant position,
1267 which means we need to derive a function like:
1269 cofmap :: (a -> b) -> (f b -> f a)
1271 This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
1273 $(cofmap 'a 'b) x = x -- when b does not contain a
1274 $(cofmap 'a 'a) x = error "type variable in contravariant position"
1275 $(cofmap 'a '(b1,b2)) x = case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
1276 $(cofmap 'a '[b]) x = map $(cofmap 'a 'b) x
1277 $(cofmap 'a '(T b1 b2)) x = fmap $(cofmap 'a 'b2) x -- when a only occurs in the last parameter, b2
1278 $(cofmap 'a '(b -> c)) x = \b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
1281 gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1282 gen_Functor_binds loc tycon
1283 = (listToBag [fmap_bind], [])
1285 data_cons = tyConDataCons tycon
1286 arg = last (tyConTyVars tycon) -- argument to derive for, 'a in the above description
1288 fmap_bind = L loc $ mkFunBind (L loc fmap_RDR) (map fmap_eqn data_cons)
1289 fmap_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1290 where parts = map derive_fmap_type (dataConOrigArgTys con)
1292 derive_fmap_type :: Type -> LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName)
1293 derive_fmap_type = functorLikeTraverse
1294 (\ x -> return x) -- fmap f x = x
1295 (\ x -> return (nlHsApp f_Expr x)) -- fmap f x = f x
1296 (panic "contravariant")
1297 (\g h x -> mkSimpleLam (\b -> h =<< (nlHsApp x `fmap` g b))) -- fmap f x = \b -> h (x (g b))
1298 (mkSimpleTupleCase match_for_con) -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
1299 (\_ g x -> do gg <- mkSimpleLam g
1300 return $ nlHsApps fmap_RDR [gg,x]) -- fmap f x = fmap g x
1301 (panic "in other argument")
1305 match_for_con = mkSimpleConMatch $
1306 \con_name xsM -> do xs <- sequence xsM
1307 return (nlHsApps con_name xs) -- Con (g1 v1) (g2 v2) ..
1310 Utility functions related to Functor deriving.
1312 Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
1313 This function works like a fold: it makes a value of type 'a' in a bottom up way.
1316 -- Generic traversal for Functor deriving
1317 functorLikeTraverse :: a -- ^ Case: does not contain variable
1318 -> a -- ^ Case: the variable itself
1319 -> a -- ^ Case: the variable itself, contravariantly
1320 -> (a -> a -> a) -- ^ Case: function type
1321 -> (Boxity -> [a] -> a) -- ^ Case: tuple type
1322 -> (Type -> a -> a) -- ^ Case: other tycon, variable only in last argument
1323 -> a -- ^ Case: other tycon, variable only in last argument
1324 -> (TcTyVar -> a -> a) -- ^ Case: forall type
1325 -> TcTyVar -- ^ Variable to look for
1326 -> Type -- ^ Type to process
1328 functorLikeTraverse caseTrivial caseVar caseCoVar caseFun caseTuple caseTyApp caseWrongArg caseForAll var ty
1330 where -- go returns (result of type a, does type contain var)
1331 go co ty | Just ty' <- coreView ty = go co ty'
1332 go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True)
1333 go co (FunTy (PredTy _) b) = go co b
1334 go co (FunTy x y) | xc || yc = (caseFun xr yr,True)
1335 where (xr,xc) = go (not co) x
1337 go co (AppTy x y) | xc = (caseWrongArg,True)
1338 | yc = (caseTyApp x yr,True)
1339 where (_, xc) = go co x
1341 go co ty@(TyConApp con args)
1342 | isTupleTyCon con = (caseTuple (tupleTyConBoxity con) xrs,True)
1343 | null args = (caseTrivial,False)
1344 | or (init xcs) = (caseWrongArg,True)
1345 | (last xcs) = (caseTyApp (fst (splitAppTy ty)) (last xrs),True)
1346 where (xrs,xcs) = unzip (map (go co) args)
1347 go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True)
1348 where (xr,xc) = go co x
1349 go _ _ = (caseTrivial,False)
1351 -- return all subtypes of ty that contain var somewhere
1352 -- these are the things that should appear in instance constraints
1353 deepSubtypesContaining :: TcTyVar -> TcType -> [TcType]
1354 deepSubtypesContaining = functorLikeTraverse
1357 (panic "contravariant")
1358 (\x y -> x ++ y) -- function
1359 (\_ xs -> concat xs) -- tuple
1360 (\ty x -> ty : x) -- tyapp
1361 (panic "in other argument")
1362 (\v x -> filter (not . (v `elemVarSet`) . tyVarsOfType) x) -- forall v
1365 -- Make a HsLam using a fresh variable from a State monad
1366 mkSimpleLam :: (LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1367 mkSimpleLam lam = do
1370 body <- lam (nlHsVar n)
1371 return (mkHsLam [nlVarPat n] body)
1373 mkSimpleLam2 :: (LHsExpr id -> LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1374 mkSimpleLam2 lam = do
1375 (n1:n2:names) <- get
1377 body <- lam (nlHsVar n1) (nlHsVar n2)
1378 return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
1380 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
1381 mkSimpleConMatch :: Monad m => (RdrName -> [a] -> m (LHsExpr RdrName)) -> [LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName)
1382 mkSimpleConMatch fold extra_pats con insides = do
1383 let con_name = getRdrName con
1384 let vars_needed = takeList insides as_RDRs
1385 let pat = nlConVarPat con_name vars_needed
1386 rhs <- fold con_name (zipWith ($) insides (map nlHsVar vars_needed))
1387 return $ mkMatch (extra_pats ++ [pat]) rhs emptyLocalBinds
1389 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
1390 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName))
1391 -> Boxity -> [LHsExpr RdrName -> a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
1392 mkSimpleTupleCase match_for_con boxity insides x = do
1393 let con = tupleCon boxity (length insides)
1394 match <- match_for_con [] con insides
1395 return $ nlHsCase x [match]
1399 %************************************************************************
1403 %************************************************************************
1405 Deriving Foldable instances works the same way as Functor instances,
1406 only Foldable instances are not possible for function types at all.
1407 Here the derived instance for the type T above is:
1409 instance Foldable T where
1410 foldr f z (T1 x1 x2 x3) = $(foldr 'a 'b1) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a 'b2) x3 z ) )
1414 $(foldr 'a 'b) x z = z -- when b does not contain a
1415 $(foldr 'a 'a) x z = f x z
1416 $(foldr 'a '(b1,b2)) x z = case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
1417 $(foldr 'a '(T b1 b2)) x z = foldr $(foldr 'a 'b2) x z -- when a only occurs in the last parameter, b2
1419 Note that the arguments to the real foldr function are the wrong way around,
1420 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
1423 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1424 gen_Foldable_binds loc tycon
1425 = (listToBag [foldr_bind], [])
1427 data_cons = tyConDataCons tycon
1428 arg = last (tyConTyVars tycon) -- argument to derive for, 'a in the above description
1430 foldr_bind = L loc $ mkFunBind (L loc foldr_RDR) (map foldr_eqn data_cons)
1431 foldr_eqn con = evalState (match_for_con z_Expr [f_Pat,z_Pat] con parts) bs_RDRs
1432 where parts = map derive_foldr_type (dataConOrigArgTys con)
1434 derive_foldr_type :: Type -> LHsExpr RdrName -> LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName)
1435 derive_foldr_type = functorLikeTraverse
1436 (\ _ z -> return z) -- foldr f z x = z
1437 (\ x z -> return (nlHsApps f_RDR [x,z])) -- foldr f z x = f x z
1440 (\b gs x z -> mkSimpleTupleCase (match_for_con z) b gs x)
1441 (\_ g x z -> do gg <- mkSimpleLam2 g -- foldr f z x = foldr (\xx zz -> g xx zz) z x
1442 return $ nlHsApps foldable_foldr_RDR [gg,z,x])
1443 (panic "in other argument")
1447 match_for_con z = mkSimpleConMatch (\_con_name -> foldrM ($) z) -- g1 v1 (g2 v2 (.. z))
1451 %************************************************************************
1453 Traversable instances
1455 %************************************************************************
1457 Again, Traversable is much like Functor and Foldable.
1461 $(traverse 'a 'b) x = pure x -- when b does not contain a
1462 $(traverse 'a 'a) x = f x
1463 $(traverse 'a '(b1,b2)) x = case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
1464 $(traverse 'a '(T b1 b2)) x = traverse $(traverse 'a 'b2) x -- when a only occurs in the last parameter, b2
1466 Note that the generated code is not as efficient as it could be. For instance:
1468 data T a = T Int a deriving Traversable
1470 gives the function: traverse f (T x y) = T <$> pure x <*> f y
1471 instead of: traverse f (T x y) = T x <$> f y
1474 gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1475 gen_Traversable_binds loc tycon
1476 = (listToBag [traverse_bind], [])
1478 data_cons = tyConDataCons tycon
1479 arg = last (tyConTyVars tycon) -- argument to derive for, 'a in the above description
1481 traverse_bind = L loc $ mkFunBind (L loc traverse_RDR) (map traverse_eqn data_cons)
1482 traverse_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1483 where parts = map derive_travese_type (dataConOrigArgTys con)
1485 derive_travese_type :: Type -> LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName)
1486 derive_travese_type = functorLikeTraverse
1487 (\ x -> return (nlHsApps pure_RDR [x])) -- traverse f x = pure x
1488 (\ x -> return (nlHsApps f_RDR [x])) -- travese f x = f x
1491 (mkSimpleTupleCase match_for_con) -- travese f x z = case x of (a1,a2,..) -> (,,) <$> g1 a1 <*> g2 a2 <*> ..
1492 (\_ g x -> do gg <- mkSimpleLam g -- travese f x = travese (\xx -> g xx) x
1493 return $ nlHsApps traverse_RDR [gg,x])
1494 (panic "in other argument")
1498 match_for_con = mkSimpleConMatch $
1499 \con_name xsM -> do xs <- sequence xsM
1500 return (mkApCon (nlHsVar con_name) xs)
1502 -- ((Con <$> x1) <*> x2) <*> ..
1503 mkApCon con [] = nlHsApps pure_RDR [con]
1504 mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
1505 where appAp x y = nlHsApps ap_RDR [x,y]
1510 %************************************************************************
1512 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1514 %************************************************************************
1519 con2tag_Foo :: Foo ... -> Int#
1520 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1521 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1524 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1528 genAuxBind :: SrcSpan -> DerivAuxBind -> LHsBind RdrName
1529 genAuxBind loc (GenCon2Tag tycon)
1530 | lots_of_constructors
1531 = mk_FunBind loc rdr_name [([], get_tag_rhs)]
1534 = mk_FunBind loc rdr_name (map mk_stuff (tyConDataCons tycon))
1537 rdr_name = con2tag_RDR tycon
1539 tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1540 -- We can't use gerRdrName because that makes an Exact RdrName
1541 -- and we can't put them in the LocalRdrEnv
1543 -- Give a signature to the bound variable, so
1544 -- that the case expression generated by getTag is
1545 -- monomorphic. In the push-enter model we get better code.
1546 get_tag_rhs = L loc $ ExprWithTySig
1547 (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1548 (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1549 (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1551 con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
1553 nlHsTyVar (getRdrName intPrimTyCon)
1555 lots_of_constructors = tyConFamilySize tycon > 8
1556 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1557 -- but we don't do vectored returns any more.
1559 mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1560 mk_stuff con = ([nlWildConPat con],
1561 nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1563 genAuxBind loc (GenTag2Con tycon)
1564 = mk_FunBind loc rdr_name
1565 [([nlConVarPat intDataCon_RDR [a_RDR]],
1566 noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1567 (nlHsTyVar (getRdrName tycon))))]
1569 rdr_name = tag2con_RDR tycon
1571 genAuxBind loc (GenMaxTag tycon)
1572 = mkVarBind loc rdr_name
1573 (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1575 rdr_name = maxtag_RDR tycon
1576 max_tag = case (tyConDataCons tycon) of
1577 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1579 genAuxBind loc (MkTyCon tycon) -- $dT
1580 = mkVarBind loc (mk_data_type_name tycon)
1581 ( nlHsVar mkDataType_RDR
1582 `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1583 `nlHsApp` nlList constrs )
1585 constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
1587 genAuxBind loc (MkDataCon dc) -- $cT1 etc
1588 = mkVarBind loc (mk_constr_name dc)
1589 (nlHsApps mkConstr_RDR constr_args)
1592 = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1593 nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
1594 nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1595 nlList labels, -- Field labels
1596 nlHsVar fixity] -- Fixity
1598 labels = map (nlHsLit . mkHsString . getOccString)
1599 (dataConFieldLabels dc)
1600 dc_occ = getOccName dc
1601 is_infix = isDataSymOcc dc_occ
1602 fixity | is_infix = infix_RDR
1603 | otherwise = prefix_RDR
1605 mk_data_type_name :: TyCon -> RdrName -- "$tT"
1606 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
1608 mk_constr_name :: DataCon -> RdrName -- "$cC"
1609 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
1612 %************************************************************************
1614 \subsection{Utility bits for generating bindings}
1616 %************************************************************************
1619 ToDo: Better SrcLocs.
1623 LHsExpr RdrName -- What to do for equality
1624 -> LHsExpr RdrName -> LHsExpr RdrName
1626 careful_compare_Case :: -- checks for primitive types...
1627 TyCon -- The tycon we are deriving for
1629 -> LHsExpr RdrName -- What to do for equality
1630 -> LHsExpr RdrName -> LHsExpr RdrName
1633 cmp_eq_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1634 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1635 -- Was: compare_gen_Case cmp_eq_RDR
1637 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1638 = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1639 compare_gen_Case eq a b -- General case
1640 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1641 [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1642 mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1643 mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1645 careful_compare_Case tycon ty eq a b
1646 | not (isUnLiftedType ty)
1647 = compare_gen_Case eq a b
1648 | otherwise -- We have to do something special for primitive things...
1649 = nlHsIf (genOpApp a relevant_lt_op b) -- Test (<) first, not (==), becuase the latter
1650 ltTag_Expr -- is true less often, so putting it first would
1651 -- mean more tests (dynamically)
1652 (nlHsIf (genOpApp a relevant_eq_op b) eq gtTag_Expr)
1654 relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1655 relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1658 box_if_necy :: String -- The class involved
1659 -> TyCon -- The tycon involved
1660 -> LHsExpr RdrName -- The argument
1661 -> Type -- The argument type
1662 -> LHsExpr RdrName -- Boxed version of the arg
1663 box_if_necy cls_str tycon arg arg_ty
1664 | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1667 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1669 assoc_ty_id :: String -- The class involved
1670 -> TyCon -- The tycon involved
1671 -> [(Type,a)] -- The table
1673 -> a -- The result of the lookup
1674 assoc_ty_id cls_str _ tbl ty
1675 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1676 text "for primitive type" <+> ppr ty)
1677 | otherwise = head res
1679 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1681 eq_op_tbl :: [(Type, PrimOp)]
1683 [(charPrimTy, CharEqOp)
1684 ,(intPrimTy, IntEqOp)
1685 ,(wordPrimTy, WordEqOp)
1686 ,(addrPrimTy, AddrEqOp)
1687 ,(floatPrimTy, FloatEqOp)
1688 ,(doublePrimTy, DoubleEqOp)
1691 lt_op_tbl :: [(Type, PrimOp)]
1693 [(charPrimTy, CharLtOp)
1694 ,(intPrimTy, IntLtOp)
1695 ,(wordPrimTy, WordLtOp)
1696 ,(addrPrimTy, AddrLtOp)
1697 ,(floatPrimTy, FloatLtOp)
1698 ,(doublePrimTy, DoubleLtOp)
1701 box_con_tbl :: [(Type, RdrName)]
1703 [(charPrimTy, getRdrName charDataCon)
1704 ,(intPrimTy, getRdrName intDataCon)
1705 ,(wordPrimTy, wordDataCon_RDR)
1706 ,(floatPrimTy, getRdrName floatDataCon)
1707 ,(doublePrimTy, getRdrName doubleDataCon)
1710 -----------------------------------------------------------------------
1712 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1713 and_Expr a b = genOpApp a and_RDR b
1715 -----------------------------------------------------------------------
1717 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1718 eq_Expr tycon ty a b = genOpApp a eq_op b
1721 | not (isUnLiftedType ty) = eq_RDR
1722 | otherwise = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1723 -- we have to do something special for primitive things...
1727 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1728 untag_Expr _ [] expr = expr
1729 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1730 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1731 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1733 cmp_tags_Expr :: RdrName -- Comparison op
1734 -> RdrName -> RdrName -- Things to compare
1735 -> LHsExpr RdrName -- What to return if true
1736 -> LHsExpr RdrName -- What to return if false
1739 cmp_tags_Expr op a b true_case false_case
1740 = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1743 :: LHsExpr RdrName -> LHsExpr RdrName
1745 enum_from_then_to_Expr
1746 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1749 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1750 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1753 :: LHsExpr RdrName -> LHsExpr RdrName
1756 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1758 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1760 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
1761 nested_compose_Expr [e] = parenify e
1762 nested_compose_Expr (e:es)
1763 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1765 -- impossible_Expr is used in case RHSs that should never happen.
1766 -- We generate these to keep the desugarer from complaining that they *might* happen!
1767 impossible_Expr :: LHsExpr RdrName
1768 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1770 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1771 -- method. It is currently only used by Enum.{succ,pred}
1772 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
1773 illegal_Expr meth tp msg =
1774 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1776 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1777 -- to include the value of a_RDR in the error string.
1778 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
1779 illegal_toEnum_tag tp maxtag =
1780 nlHsApp (nlHsVar error_RDR)
1781 (nlHsApp (nlHsApp (nlHsVar append_RDR)
1782 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1783 (nlHsApp (nlHsApp (nlHsApp
1784 (nlHsVar showsPrec_RDR)
1788 (nlHsVar append_RDR)
1789 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1790 (nlHsApp (nlHsApp (nlHsApp
1791 (nlHsVar showsPrec_RDR)
1794 (nlHsLit (mkHsString ")"))))))
1796 parenify :: LHsExpr RdrName -> LHsExpr RdrName
1797 parenify e@(L _ (HsVar _)) = e
1798 parenify e = mkHsPar e
1800 -- genOpApp wraps brackets round the operator application, so that the
1801 -- renamer won't subsequently try to re-associate it.
1802 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1803 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1807 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR,
1808 cmp_eq_RDR :: RdrName
1809 a_RDR = mkVarUnqual (fsLit "a")
1810 b_RDR = mkVarUnqual (fsLit "b")
1811 c_RDR = mkVarUnqual (fsLit "c")
1812 d_RDR = mkVarUnqual (fsLit "d")
1813 f_RDR = mkVarUnqual (fsLit "f")
1814 k_RDR = mkVarUnqual (fsLit "k")
1815 z_RDR = mkVarUnqual (fsLit "z")
1816 ah_RDR = mkVarUnqual (fsLit "a#")
1817 bh_RDR = mkVarUnqual (fsLit "b#")
1818 ch_RDR = mkVarUnqual (fsLit "c#")
1819 dh_RDR = mkVarUnqual (fsLit "d#")
1820 cmp_eq_RDR = mkVarUnqual (fsLit "cmp_eq")
1822 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
1823 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1824 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1825 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1827 a_Expr, b_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
1828 false_Expr, true_Expr :: LHsExpr RdrName
1829 a_Expr = nlHsVar a_RDR
1830 b_Expr = nlHsVar b_RDR
1831 c_Expr = nlHsVar c_RDR
1832 f_Expr = nlHsVar f_RDR
1833 z_Expr = nlHsVar z_RDR
1834 ltTag_Expr = nlHsVar ltTag_RDR
1835 eqTag_Expr = nlHsVar eqTag_RDR
1836 gtTag_Expr = nlHsVar gtTag_RDR
1837 false_Expr = nlHsVar false_RDR
1838 true_Expr = nlHsVar true_RDR
1840 a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName
1841 a_Pat = nlVarPat a_RDR
1842 b_Pat = nlVarPat b_RDR
1843 c_Pat = nlVarPat c_RDR
1844 d_Pat = nlVarPat d_RDR
1845 f_Pat = nlVarPat f_RDR
1846 k_Pat = nlVarPat k_RDR
1847 z_Pat = nlVarPat z_RDR
1849 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1850 -- Generates Orig s RdrName, for the binding positions
1851 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
1852 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
1853 maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc
1855 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
1856 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
1858 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
1859 mkAuxBinderName parent occ_fun = mkRdrUnqual (occ_fun (nameOccName parent))
1860 -- Was: mkDerivedRdrName name occ_fun, which made an original name
1861 -- But: (a) that does not work well for standalone-deriving
1862 -- (b) an unqualified name is just fine, provided it can't clash with user code
1865 s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
1866 PrelNames, so PrelNames can't import PrimOp.
1869 primOpRdrName :: PrimOp -> RdrName
1870 primOpRdrName op = getRdrName (primOpId op)
1872 minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, leInt_RDR,
1873 tagToEnum_RDR :: RdrName
1874 minusInt_RDR = primOpRdrName IntSubOp
1875 eqInt_RDR = primOpRdrName IntEqOp
1876 ltInt_RDR = primOpRdrName IntLtOp
1877 geInt_RDR = primOpRdrName IntGeOp
1878 leInt_RDR = primOpRdrName IntLeOp
1879 tagToEnum_RDR = primOpRdrName TagToEnumOp
1881 error_RDR :: RdrName
1882 error_RDR = getRdrName eRROR_ID