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,
27 FFoldType(..), functorLikeTraverse,
28 deepSubtypesContaining, foldDataConArgs,
30 gen_Traversable_binds,
34 #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 = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
570 max_bound_enum = mkHsVarBind 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 = mkHsVarBind loc minBound_RDR $
581 nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
582 max_bound_1con = mkHsVarBind 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 (mkLHsVarTuple [a,b]))
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 (mkLHsVarTuple [l,u]))
744 ) times_RDR (mk_index rest)
747 = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], 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 [mkLHsVarTuple [a,b], nlHsVar c]
759 %************************************************************************
763 %************************************************************************
773 instance Read T where
777 do x <- ReadP.step Read.readPrec
778 Symbol "%%" <- Lex.lex
779 y <- ReadP.step Read.readPrec
783 -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
784 -- Record construction binds even more tightly than application
785 do Ident "T1" <- Lex.lex
787 Ident "f1" <- Lex.lex
789 x <- ReadP.reset Read.readPrec
791 return (T1 { f1 = x }))
794 do Ident "T2" <- Lex.lexP
795 x <- ReadP.step Read.readPrec
799 readListPrec = readListPrecDefault
800 readList = readListDefault
804 gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
806 gen_Read_binds get_fixity loc tycon
807 = (listToBag [read_prec, default_readlist, default_readlistprec], [])
809 -----------------------------------------------------------------------
811 = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
814 = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
815 -----------------------------------------------------------------------
817 data_cons = tyConDataCons tycon
818 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
820 read_prec = mkHsVarBind loc readPrec_RDR
821 (nlHsApp (nlHsVar parens_RDR) read_cons)
823 read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
824 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
827 = case nullary_cons of
829 [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
830 (result_expr con [])]
831 _ -> [nlHsApp (nlHsVar choose_RDR)
832 (nlList (map mk_pair nullary_cons))]
834 mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),
837 read_non_nullary_con data_con
838 | is_infix = mk_parser infix_prec infix_stmts body
839 | is_record = mk_parser record_prec record_stmts body
840 -- Using these two lines instead allows the derived
841 -- read for infix and record bindings to read the prefix form
842 -- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body)
843 -- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
844 | otherwise = prefix_parser
846 body = result_expr data_con as_needed
847 con_str = data_con_str data_con
849 prefix_parser = mk_parser prefix_prec prefix_stmts body
852 | isSym con_str = [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"]
853 | otherwise = [bindLex (ident_pat con_str)]
856 | isSym con_str = [bindLex (symbol_pat con_str)]
857 | otherwise = [read_punc "`", bindLex (ident_pat con_str), read_punc "`"]
859 prefix_stmts -- T a b c
860 = read_prefix_con ++ read_args
862 infix_stmts -- a %% b, or a `T` b
867 record_stmts -- T { f1 = a, f2 = b }
870 ++ concat (intersperse [read_punc ","] field_stmts)
873 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
875 con_arity = dataConSourceArity data_con
876 labels = dataConFieldLabels data_con
877 dc_nm = getName data_con
878 is_infix = dataConIsInfix data_con
879 is_record = length labels > 0
880 as_needed = take con_arity as_RDRs
881 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
882 (read_a1:read_a2:_) = read_args
884 prefix_prec = appPrecedence
885 infix_prec = getPrecedence get_fixity dc_nm
886 record_prec = appPrecedence + 1 -- Record construction binds even more tightly
887 -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
889 ------------------------------------------------------------------------
891 ------------------------------------------------------------------------
892 mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
893 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b] -- prec p (do { ss ; b })
894 bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP
895 con_app con as = nlHsVarApps (getRdrName con) as -- con as
896 result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
898 punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
899 ident_pat s = nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo"
900 symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>"
902 data_con_str con = occNameString (getOccName con)
904 read_punc c = bindLex (punc_pat c)
905 read_arg a ty = ASSERT( not (isUnLiftedType ty) )
906 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
908 read_field lbl a = read_lbl lbl ++
910 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
912 -- When reading field labels we might encounter
917 read_lbl lbl | isSym lbl_str
919 bindLex (symbol_pat lbl_str),
922 = [bindLex (ident_pat lbl_str)]
924 lbl_str = occNameString (getOccName lbl)
928 %************************************************************************
932 %************************************************************************
938 data Tree a = Leaf a | Tree a :^: Tree a
940 instance (Show a) => Show (Tree a) where
942 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
944 showStr = showString "Leaf " . showsPrec (app_prec+1) m
946 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
948 showStr = showsPrec (up_prec+1) u .
950 showsPrec (up_prec+1) v
951 -- Note: right-associativity of :^: ignored
953 up_prec = 5 -- Precedence of :^:
954 app_prec = 10 -- Application has precedence one more than
955 -- the most tightly-binding operator
958 gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
960 gen_Show_binds get_fixity loc tycon
961 = (listToBag [shows_prec, show_list], [])
963 -----------------------------------------------------------------------
964 show_list = mkHsVarBind loc showList_RDR
965 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
966 -----------------------------------------------------------------------
967 shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
970 | nullary_con = -- skip the showParen junk...
971 ASSERT(null bs_needed)
972 ([nlWildPat, con_pat], mk_showString_app con_str)
975 showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
976 (nlHsPar (nested_compose_Expr show_thingies)))
978 data_con_RDR = getRdrName data_con
979 con_arity = dataConSourceArity data_con
980 bs_needed = take con_arity bs_RDRs
981 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
982 con_pat = nlConVarPat data_con_RDR bs_needed
983 nullary_con = con_arity == 0
984 labels = dataConFieldLabels data_con
985 lab_fields = length labels
986 record_syntax = lab_fields > 0
988 dc_nm = getName data_con
989 dc_occ_nm = getOccName data_con
990 con_str = occNameString dc_occ_nm
991 op_con_str = wrapOpParens con_str
992 backquote_str = wrapOpBackquotes con_str
995 | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
996 | record_syntax = mk_showString_app (op_con_str ++ " {") :
997 show_record_args ++ [mk_showString_app "}"]
998 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
1000 show_label l = mk_showString_app (nm ++ " = ")
1001 -- Note the spaces around the "=" sign. If we don't have them
1002 -- then we get Foo { x=-1 } and the "=-" parses as a single
1003 -- lexeme. Only the space after the '=' is necessary, but
1004 -- it seems tidier to have them both sides.
1006 occ_nm = getOccName l
1007 nm = wrapOpParens (occNameString occ_nm)
1009 show_args = zipWith show_arg bs_needed arg_tys
1010 (show_arg1:show_arg2:_) = show_args
1011 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
1013 -- Assumption for record syntax: no of fields == no of labelled fields
1014 -- (and in same order)
1015 show_record_args = concat $
1016 intersperse [mk_showString_app ", "] $
1017 [ [show_label lbl, arg]
1018 | (lbl,arg) <- zipEqual "gen_Show_binds"
1021 -- Generates (showsPrec p x) for argument x, but it also boxes
1022 -- the argument first if necessary. Note that this prints unboxed
1023 -- things without any '#' decorations; could change that if need be
1024 show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
1025 box_if_necy "Show" tycon (nlHsVar b) arg_ty]
1028 is_infix = dataConIsInfix data_con
1029 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1030 arg_prec | record_syntax = 0 -- Record fields don't need parens
1031 | otherwise = con_prec_plus_one
1033 wrapOpParens :: String -> String
1034 wrapOpParens s | isSym s = '(' : s ++ ")"
1037 wrapOpBackquotes :: String -> String
1038 wrapOpBackquotes s | isSym s = s
1039 | otherwise = '`' : s ++ "`"
1041 isSym :: String -> Bool
1043 isSym (c : _) = startsVarSym c || startsConSym c
1045 mk_showString_app :: String -> LHsExpr RdrName
1046 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1050 getPrec :: Bool -> FixityEnv -> Name -> Integer
1051 getPrec is_infix get_fixity nm
1052 | not is_infix = appPrecedence
1053 | otherwise = getPrecedence get_fixity nm
1055 appPrecedence :: Integer
1056 appPrecedence = fromIntegral maxPrecedence + 1
1057 -- One more than the precedence of the most
1058 -- tightly-binding operator
1060 getPrecedence :: FixityEnv -> Name -> Integer
1061 getPrecedence get_fixity nm
1062 = case lookupFixity get_fixity nm of
1063 Fixity x _assoc -> fromIntegral x
1064 -- NB: the Report says that associativity is not taken
1065 -- into account for either Read or Show; hence we
1066 -- ignore associativity here
1070 %************************************************************************
1072 \subsection{Typeable}
1074 %************************************************************************
1082 instance Typeable2 T where
1083 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1085 We are passed the Typeable2 class as well as T
1088 gen_Typeable_binds :: SrcSpan -> TyCon -> LHsBinds RdrName
1089 gen_Typeable_binds loc tycon
1092 (mk_typeOf_RDR tycon) -- Name of appropriate type0f function
1094 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1096 tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
1098 mk_typeOf_RDR :: TyCon -> RdrName
1099 -- Use the arity of the TyCon to make the right typeOfn function
1100 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1102 arity = tyConArity tycon
1103 suffix | arity == 0 = ""
1104 | otherwise = show arity
1109 %************************************************************************
1113 %************************************************************************
1117 data T a b = T1 a b | T2
1121 $cT1 = mkDataCon $dT "T1" Prefix
1122 $cT2 = mkDataCon $dT "T2" Prefix
1123 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1124 -- the [] is for field labels.
1126 instance (Data a, Data b) => Data (T a b) where
1127 gfoldl k z (T1 a b) = z T `k` a `k` b
1128 gfoldl k z T2 = z T2
1129 -- ToDo: add gmapT,Q,M, gfoldr
1131 gunfold k z c = case conIndex c of
1132 I# 1# -> k (k (z T1))
1135 toConstr (T1 _ _) = $cT1
1140 dataCast1 = gcast1 -- If T :: * -> *
1141 dataCast2 = gcast2 -- if T :: * -> * -> *
1145 gen_Data_binds :: SrcSpan
1147 -> (LHsBinds RdrName, -- The method bindings
1148 DerivAuxBinds) -- Auxiliary bindings
1149 gen_Data_binds loc tycon
1150 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
1151 `unionBags` gcast_binds,
1152 -- Auxiliary definitions: the data type and constructors
1153 MkTyCon tycon : map MkDataCon data_cons)
1155 data_cons = tyConDataCons tycon
1156 n_cons = length data_cons
1157 one_constr = n_cons == 1
1160 gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons)
1161 gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1162 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1165 con_name = getRdrName con
1166 as_needed = take (dataConSourceArity con) as_RDRs
1167 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1169 ------------ gunfold
1170 gunfold_bind = mk_FunBind loc
1172 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1176 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1177 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1178 (map gunfold_alt data_cons)
1180 gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1181 mk_unfold_rhs dc = foldr nlHsApp
1182 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1183 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1185 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1186 -- redundant test, and annoying warning
1187 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1188 | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1192 ------------ toConstr
1193 toCon_bind = mk_FunBind loc toConstr_RDR (map to_con_eqn data_cons)
1194 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1196 ------------ dataTypeOf
1197 dataTypeOf_bind = mk_easy_FunBind
1201 (nlHsVar (mk_data_type_name tycon))
1203 ------------ gcast1/2
1204 tycon_kind = tyConKind tycon
1205 gcast_binds | tycon_kind `eqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR
1206 | tycon_kind `eqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
1207 | otherwise = emptyBag
1208 mk_gcast dataCast_RDR gcast_RDR
1209 = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
1210 (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
1213 kind1, kind2 :: Kind
1214 kind1 = liftedTypeKind `mkArrowKind` liftedTypeKind
1215 kind2 = liftedTypeKind `mkArrowKind` kind1
1217 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
1218 mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
1219 dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR :: RdrName
1220 gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
1221 gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
1222 toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
1223 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1224 dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1")
1225 dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2")
1226 gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1")
1227 gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2")
1228 mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
1229 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1230 conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
1231 prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix")
1232 infix_RDR = dataQual_RDR gENERICS (fsLit "Infix")
1237 %************************************************************************
1241 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1244 %************************************************************************
1248 data T a = T1 Int a | T2 (T a)
1250 We generate the instance:
1252 instance Functor T where
1253 fmap f (T1 b1 a) = T1 b1 (f a)
1254 fmap f (T2 ta) = T2 (fmap f ta)
1256 Notice that we don't simply apply 'fmap' to the constructor arguments.
1258 - Do nothing to an argument whose type doesn't mention 'a'
1259 - Apply 'f' to an argument of type 'a'
1260 - Apply 'fmap f' to other arguments
1261 That's why we have to recurse deeply into the constructor argument types,
1262 rather than just one level, as we typically do.
1264 What about types with more than one type parameter? In general, we only
1265 derive Functor for the last position:
1267 data S a b = S1 [b] | S2 (a, T a b)
1268 instance Functor (S a) where
1269 fmap f (S1 bs) = S1 (fmap f bs)
1270 fmap f (S2 (p,q)) = S2 (a, fmap f q)
1272 However, we have special cases for
1276 More formally, we write the derivation of fmap code over type variable
1277 'a for type 'b as ($fmap 'a 'b). In this general notation the derived
1280 instance Functor T where
1281 fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
1282 fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1)
1284 $(fmap 'a 'b) x = x -- when b does not contain a
1285 $(fmap 'a 'a) x = f x
1286 $(fmap 'a '(b1,b2)) x = case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
1287 $(fmap 'a '(T b1 b2)) x = fmap $(fmap 'a 'b2) x -- when a only occurs in the last parameter, b2
1288 $(fmap 'a '(b -> c)) x = \b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
1290 For functions, the type parameter 'a can occur in a contravariant position,
1291 which means we need to derive a function like:
1293 cofmap :: (a -> b) -> (f b -> f a)
1295 This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
1297 $(cofmap 'a 'b) x = x -- when b does not contain a
1298 $(cofmap 'a 'a) x = error "type variable in contravariant position"
1299 $(cofmap 'a '(b1,b2)) x = case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
1300 $(cofmap 'a '[b]) x = map $(cofmap 'a 'b) x
1301 $(cofmap 'a '(T b1 b2)) x = fmap $(cofmap 'a 'b2) x -- when a only occurs in the last parameter, b2
1302 $(cofmap 'a '(b -> c)) x = \b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
1305 gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1306 gen_Functor_binds loc tycon
1307 = (unitBag fmap_bind, [])
1309 data_cons = tyConDataCons tycon
1311 fmap_bind = L loc $ mkFunBind (L loc fmap_RDR) (map fmap_eqn data_cons)
1312 fmap_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1314 parts = foldDataConArgs ft_fmap con
1316 ft_fmap :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1317 -- Tricky higher order type; I can't say I fully understand this code :-(
1318 ft_fmap = FT { ft_triv = \x -> return x -- fmap f x = x
1319 , ft_var = \x -> return (nlHsApp f_Expr x) -- fmap f x = f x
1320 , ft_fun = \g h x -> mkSimpleLam (\b -> h =<< (nlHsApp x `fmap` g b))
1321 -- fmap f x = \b -> h (x (g b))
1322 , ft_tup = mkSimpleTupleCase match_for_con -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
1323 , ft_ty_app = \_ g x -> do gg <- mkSimpleLam g -- fmap f x = fmap g x
1324 return $ nlHsApps fmap_RDR [gg,x]
1325 , ft_forall = \_ g x -> g x
1326 , ft_bad_app = panic "in other argument"
1327 , ft_co_var = panic "contravariant" }
1329 match_for_con = mkSimpleConMatch $
1330 \con_name xsM -> do xs <- sequence xsM
1331 return (nlHsApps con_name xs) -- Con (g1 v1) (g2 v2) ..
1334 Utility functions related to Functor deriving.
1336 Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
1337 This function works like a fold: it makes a value of type 'a' in a bottom up way.
1340 -- Generic traversal for Functor deriving
1341 data FFoldType a -- Describes how to fold over a Type in a functor like way
1342 = FT { ft_triv :: a -- Does not contain variable
1343 , ft_var :: a -- The variable itself
1344 , ft_co_var :: a -- The variable itself, contravariantly
1345 , ft_fun :: a -> a -> a -- Function type
1346 , ft_tup :: Boxity -> [a] -> a -- Tuple type
1347 , ft_ty_app :: Type -> a -> a -- Type app, variable only in last argument
1348 , ft_bad_app :: a -- Type app, variable other than in last argument
1349 , ft_forall :: TcTyVar -> a -> a -- Forall type
1352 functorLikeTraverse :: TyVar -- ^ Variable to look for
1353 -> FFoldType a -- ^ How to fold
1354 -> Type -- ^ Type to process
1356 functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar
1357 , ft_co_var = caseCoVar, ft_fun = caseFun
1358 , ft_tup = caseTuple, ft_ty_app = caseTyApp
1359 , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
1362 where -- go returns (result of type a, does type contain var)
1363 go co ty | Just ty' <- coreView ty = go co ty'
1364 go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True)
1365 go co (FunTy (PredTy _) b) = go co b
1366 go co (FunTy x y) | xc || yc = (caseFun xr yr,True)
1367 where (xr,xc) = go (not co) x
1369 go co (AppTy x y) | xc = (caseWrongArg, True)
1370 | yc = (caseTyApp x yr, True)
1371 where (_, xc) = go co x
1373 go co ty@(TyConApp con args)
1374 | isTupleTyCon con = (caseTuple (tupleTyConBoxity con) xrs,True)
1375 | null args = (caseTrivial,False) -- T
1376 | or (init xcs) = (caseWrongArg,True) -- T (..var..) ty
1377 | last xcs = -- T (..no var..) ty
1378 (caseTyApp (fst (splitAppTy ty)) (last xrs),True)
1379 where (xrs,xcs) = unzip (map (go co) args)
1380 go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True)
1381 where (xr,xc) = go co x
1382 go _ _ = (caseTrivial,False)
1384 -- Return all syntactic subterms of ty that contain var somewhere
1385 -- These are the things that should appear in instance constraints
1386 deepSubtypesContaining :: TyVar -> Type -> [TcType]
1387 deepSubtypesContaining tv
1388 = functorLikeTraverse tv
1391 , ft_fun = (++), ft_tup = \_ xs -> concat xs
1393 , ft_bad_app = panic "in other argument"
1394 , ft_co_var = panic "contravariant"
1395 , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyVarsOfType) xs })
1398 foldDataConArgs :: FFoldType a -> DataCon -> [a]
1399 -- Fold over the arguments of the datacon
1400 foldDataConArgs ft con
1401 = map (functorLikeTraverse tv ft) (dataConOrigArgTys con)
1403 tv = last (dataConUnivTyVars con)
1404 -- Argument to derive for, 'a in the above description
1405 -- The validity checks have ensured that con is
1406 -- a vanilla data constructor
1408 -- Make a HsLam using a fresh variable from a State monad
1409 mkSimpleLam :: (LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1410 -- (mkSimpleLam fn) returns (\x. fn(x))
1411 mkSimpleLam lam = do
1414 body <- lam (nlHsVar n)
1415 return (mkHsLam [nlVarPat n] body)
1417 mkSimpleLam2 :: (LHsExpr id -> LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1418 mkSimpleLam2 lam = do
1419 (n1:n2:names) <- get
1421 body <- lam (nlHsVar n1) (nlHsVar n2)
1422 return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
1424 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
1425 mkSimpleConMatch :: Monad m => (RdrName -> [a] -> m (LHsExpr RdrName)) -> [LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName)
1426 mkSimpleConMatch fold extra_pats con insides = do
1427 let con_name = getRdrName con
1428 let vars_needed = takeList insides as_RDRs
1429 let pat = nlConVarPat con_name vars_needed
1430 rhs <- fold con_name (zipWith ($) insides (map nlHsVar vars_needed))
1431 return $ mkMatch (extra_pats ++ [pat]) rhs emptyLocalBinds
1433 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
1434 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName))
1435 -> Boxity -> [LHsExpr RdrName -> a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
1436 mkSimpleTupleCase match_for_con boxity insides x = do
1437 let con = tupleCon boxity (length insides)
1438 match <- match_for_con [] con insides
1439 return $ nlHsCase x [match]
1443 %************************************************************************
1447 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1450 %************************************************************************
1452 Deriving Foldable instances works the same way as Functor instances,
1453 only Foldable instances are not possible for function types at all.
1454 Here the derived instance for the type T above is:
1456 instance Foldable T where
1457 foldr f z (T1 x1 x2 x3) = $(foldr 'a 'b1) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a 'b2) x3 z ) )
1461 $(foldr 'a 'b) x z = z -- when b does not contain a
1462 $(foldr 'a 'a) x z = f x z
1463 $(foldr 'a '(b1,b2)) x z = case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
1464 $(foldr 'a '(T b1 b2)) x z = foldr $(foldr 'a 'b2) x z -- when a only occurs in the last parameter, b2
1466 Note that the arguments to the real foldr function are the wrong way around,
1467 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
1470 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1471 gen_Foldable_binds loc tycon
1472 = (unitBag foldr_bind, [])
1474 data_cons = tyConDataCons tycon
1476 foldr_bind = L loc $ mkFunBind (L loc foldable_foldr_RDR) (map foldr_eqn data_cons)
1477 foldr_eqn con = evalState (match_for_con z_Expr [f_Pat,z_Pat] con parts) bs_RDRs
1479 parts = foldDataConArgs ft_foldr con
1481 ft_foldr :: FFoldType (LHsExpr RdrName -> LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1482 ft_foldr = FT { ft_triv = \_ z -> return z -- foldr f z x = z
1483 , ft_var = \x z -> return (nlHsApps f_RDR [x,z]) -- foldr f z x = f x z
1484 , ft_tup = \b gs x z -> mkSimpleTupleCase (match_for_con z) b gs x
1485 , ft_ty_app = \_ g x z -> do gg <- mkSimpleLam2 g -- foldr f z x = foldr (\xx zz -> g xx zz) z x
1486 return $ nlHsApps foldable_foldr_RDR [gg,z,x]
1487 , ft_forall = \_ g x z -> g x z
1488 , ft_co_var = panic "covariant"
1489 , ft_fun = panic "function"
1490 , ft_bad_app = panic "in other argument" }
1492 match_for_con z = mkSimpleConMatch (\_con_name -> foldrM ($) z) -- g1 v1 (g2 v2 (.. z))
1496 %************************************************************************
1498 Traversable instances
1500 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1502 %************************************************************************
1504 Again, Traversable is much like Functor and Foldable.
1508 $(traverse 'a 'b) x = pure x -- when b does not contain a
1509 $(traverse 'a 'a) x = f x
1510 $(traverse 'a '(b1,b2)) x = case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
1511 $(traverse 'a '(T b1 b2)) x = traverse $(traverse 'a 'b2) x -- when a only occurs in the last parameter, b2
1513 Note that the generated code is not as efficient as it could be. For instance:
1515 data T a = T Int a deriving Traversable
1517 gives the function: traverse f (T x y) = T <$> pure x <*> f y
1518 instead of: traverse f (T x y) = T x <$> f y
1521 gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1522 gen_Traversable_binds loc tycon
1523 = (unitBag traverse_bind, [])
1525 data_cons = tyConDataCons tycon
1527 traverse_bind = L loc $ mkFunBind (L loc traverse_RDR) (map traverse_eqn data_cons)
1528 traverse_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1530 parts = foldDataConArgs ft_trav con
1533 ft_trav :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1534 ft_trav = FT { ft_triv = \x -> return (nlHsApps pure_RDR [x]) -- traverse f x = pure x
1535 , ft_var = \x -> return (nlHsApps f_RDR [x]) -- travese f x = f x
1536 , ft_tup = mkSimpleTupleCase match_for_con -- travese f x z = case x of (a1,a2,..) ->
1537 -- (,,) <$> g1 a1 <*> g2 a2 <*> ..
1538 , ft_ty_app = \_ g x -> do gg <- mkSimpleLam g -- travese f x = travese (\xx -> g xx) x
1539 return $ nlHsApps traverse_RDR [gg,x]
1540 , ft_forall = \_ g x -> g x
1541 , ft_co_var = panic "covariant"
1542 , ft_fun = panic "function"
1543 , ft_bad_app = panic "in other argument" }
1545 match_for_con = mkSimpleConMatch $
1546 \con_name xsM -> do xs <- sequence xsM
1547 return (mkApCon (nlHsVar con_name) xs)
1549 -- ((Con <$> x1) <*> x2) <*> ..
1550 mkApCon con [] = nlHsApps pure_RDR [con]
1551 mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
1552 where appAp x y = nlHsApps ap_RDR [x,y]
1557 %************************************************************************
1559 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1561 %************************************************************************
1566 con2tag_Foo :: Foo ... -> Int#
1567 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1568 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1571 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1575 genAuxBind :: SrcSpan -> DerivAuxBind -> LHsBind RdrName
1576 genAuxBind loc (GenCon2Tag tycon)
1577 | lots_of_constructors
1578 = mk_FunBind loc rdr_name [([], get_tag_rhs)]
1581 = mk_FunBind loc rdr_name (map mk_stuff (tyConDataCons tycon))
1584 rdr_name = con2tag_RDR tycon
1586 tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1587 -- We can't use gerRdrName because that makes an Exact RdrName
1588 -- and we can't put them in the LocalRdrEnv
1590 -- Give a signature to the bound variable, so
1591 -- that the case expression generated by getTag is
1592 -- monomorphic. In the push-enter model we get better code.
1593 get_tag_rhs = L loc $ ExprWithTySig
1594 (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1595 (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1596 (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1598 con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
1600 nlHsTyVar (getRdrName intPrimTyCon)
1602 lots_of_constructors = tyConFamilySize tycon > 8
1603 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1604 -- but we don't do vectored returns any more.
1606 mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1607 mk_stuff con = ([nlWildConPat con],
1608 nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1610 genAuxBind loc (GenTag2Con tycon)
1611 = mk_FunBind loc rdr_name
1612 [([nlConVarPat intDataCon_RDR [a_RDR]],
1613 noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1614 (nlHsTyVar (getRdrName tycon))))]
1616 rdr_name = tag2con_RDR tycon
1618 genAuxBind loc (GenMaxTag tycon)
1619 = mkHsVarBind loc rdr_name
1620 (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1622 rdr_name = maxtag_RDR tycon
1623 max_tag = case (tyConDataCons tycon) of
1624 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1626 genAuxBind loc (MkTyCon tycon) -- $dT
1627 = mkHsVarBind loc (mk_data_type_name tycon)
1628 ( nlHsVar mkDataType_RDR
1629 `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
1630 `nlHsApp` nlList constrs )
1632 constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
1634 genAuxBind loc (MkDataCon dc) -- $cT1 etc
1635 = mkHsVarBind loc (mk_constr_name dc)
1636 (nlHsApps mkConstr_RDR constr_args)
1639 = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1640 nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
1641 nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1642 nlList labels, -- Field labels
1643 nlHsVar fixity] -- Fixity
1645 labels = map (nlHsLit . mkHsString . getOccString)
1646 (dataConFieldLabels dc)
1647 dc_occ = getOccName dc
1648 is_infix = isDataSymOcc dc_occ
1649 fixity | is_infix = infix_RDR
1650 | otherwise = prefix_RDR
1652 mk_data_type_name :: TyCon -> RdrName -- "$tT"
1653 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
1655 mk_constr_name :: DataCon -> RdrName -- "$cC"
1656 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
1659 %************************************************************************
1661 \subsection{Utility bits for generating bindings}
1663 %************************************************************************
1666 ToDo: Better SrcLocs.
1670 LHsExpr RdrName -- What to do for equality
1671 -> LHsExpr RdrName -> LHsExpr RdrName
1673 careful_compare_Case :: -- checks for primitive types...
1674 TyCon -- The tycon we are deriving for
1676 -> LHsExpr RdrName -- What to do for equality
1677 -> LHsExpr RdrName -> LHsExpr RdrName
1680 cmp_eq_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1681 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1682 -- Was: compare_gen_Case cmp_eq_RDR
1684 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1685 = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1686 compare_gen_Case eq a b -- General case
1687 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1688 [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1689 mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1690 mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1692 careful_compare_Case tycon ty eq a b
1693 | not (isUnLiftedType ty)
1694 = compare_gen_Case eq a b
1695 | otherwise -- We have to do something special for primitive things...
1696 = nlHsIf (genOpApp a relevant_lt_op b) -- Test (<) first, not (==), becuase the latter
1697 ltTag_Expr -- is true less often, so putting it first would
1698 -- mean more tests (dynamically)
1699 (nlHsIf (genOpApp a relevant_eq_op b) eq gtTag_Expr)
1701 relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1702 relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1705 box_if_necy :: String -- The class involved
1706 -> TyCon -- The tycon involved
1707 -> LHsExpr RdrName -- The argument
1708 -> Type -- The argument type
1709 -> LHsExpr RdrName -- Boxed version of the arg
1710 box_if_necy cls_str tycon arg arg_ty
1711 | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1714 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1716 assoc_ty_id :: String -- The class involved
1717 -> TyCon -- The tycon involved
1718 -> [(Type,a)] -- The table
1720 -> a -- The result of the lookup
1721 assoc_ty_id cls_str _ tbl ty
1722 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1723 text "for primitive type" <+> ppr ty)
1724 | otherwise = head res
1726 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1728 eq_op_tbl :: [(Type, PrimOp)]
1730 [(charPrimTy, CharEqOp)
1731 ,(intPrimTy, IntEqOp)
1732 ,(wordPrimTy, WordEqOp)
1733 ,(addrPrimTy, AddrEqOp)
1734 ,(floatPrimTy, FloatEqOp)
1735 ,(doublePrimTy, DoubleEqOp)
1738 lt_op_tbl :: [(Type, PrimOp)]
1740 [(charPrimTy, CharLtOp)
1741 ,(intPrimTy, IntLtOp)
1742 ,(wordPrimTy, WordLtOp)
1743 ,(addrPrimTy, AddrLtOp)
1744 ,(floatPrimTy, FloatLtOp)
1745 ,(doublePrimTy, DoubleLtOp)
1748 box_con_tbl :: [(Type, RdrName)]
1750 [(charPrimTy, getRdrName charDataCon)
1751 ,(intPrimTy, getRdrName intDataCon)
1752 ,(wordPrimTy, wordDataCon_RDR)
1753 ,(floatPrimTy, getRdrName floatDataCon)
1754 ,(doublePrimTy, getRdrName doubleDataCon)
1757 -----------------------------------------------------------------------
1759 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1760 and_Expr a b = genOpApp a and_RDR b
1762 -----------------------------------------------------------------------
1764 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1765 eq_Expr tycon ty a b = genOpApp a eq_op b
1768 | not (isUnLiftedType ty) = eq_RDR
1769 | otherwise = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1770 -- we have to do something special for primitive things...
1774 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1775 untag_Expr _ [] expr = expr
1776 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1777 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1778 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1780 cmp_tags_Expr :: RdrName -- Comparison op
1781 -> RdrName -> RdrName -- Things to compare
1782 -> LHsExpr RdrName -- What to return if true
1783 -> LHsExpr RdrName -- What to return if false
1786 cmp_tags_Expr op a b true_case false_case
1787 = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1790 :: LHsExpr RdrName -> LHsExpr RdrName
1792 enum_from_then_to_Expr
1793 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1796 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1797 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1800 :: LHsExpr RdrName -> LHsExpr RdrName
1803 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1805 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1807 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
1808 nested_compose_Expr [e] = parenify e
1809 nested_compose_Expr (e:es)
1810 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1812 -- impossible_Expr is used in case RHSs that should never happen.
1813 -- We generate these to keep the desugarer from complaining that they *might* happen!
1814 impossible_Expr :: LHsExpr RdrName
1815 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1817 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1818 -- method. It is currently only used by Enum.{succ,pred}
1819 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
1820 illegal_Expr meth tp msg =
1821 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1823 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1824 -- to include the value of a_RDR in the error string.
1825 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
1826 illegal_toEnum_tag tp maxtag =
1827 nlHsApp (nlHsVar error_RDR)
1828 (nlHsApp (nlHsApp (nlHsVar append_RDR)
1829 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1830 (nlHsApp (nlHsApp (nlHsApp
1831 (nlHsVar showsPrec_RDR)
1835 (nlHsVar append_RDR)
1836 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1837 (nlHsApp (nlHsApp (nlHsApp
1838 (nlHsVar showsPrec_RDR)
1841 (nlHsLit (mkHsString ")"))))))
1843 parenify :: LHsExpr RdrName -> LHsExpr RdrName
1844 parenify e@(L _ (HsVar _)) = e
1845 parenify e = mkHsPar e
1847 -- genOpApp wraps brackets round the operator application, so that the
1848 -- renamer won't subsequently try to re-associate it.
1849 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1850 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1854 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR,
1855 cmp_eq_RDR :: RdrName
1856 a_RDR = mkVarUnqual (fsLit "a")
1857 b_RDR = mkVarUnqual (fsLit "b")
1858 c_RDR = mkVarUnqual (fsLit "c")
1859 d_RDR = mkVarUnqual (fsLit "d")
1860 f_RDR = mkVarUnqual (fsLit "f")
1861 k_RDR = mkVarUnqual (fsLit "k")
1862 z_RDR = mkVarUnqual (fsLit "z")
1863 ah_RDR = mkVarUnqual (fsLit "a#")
1864 bh_RDR = mkVarUnqual (fsLit "b#")
1865 ch_RDR = mkVarUnqual (fsLit "c#")
1866 dh_RDR = mkVarUnqual (fsLit "d#")
1867 cmp_eq_RDR = mkVarUnqual (fsLit "cmp_eq")
1869 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
1870 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1871 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1872 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1874 a_Expr, b_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
1875 false_Expr, true_Expr :: LHsExpr RdrName
1876 a_Expr = nlHsVar a_RDR
1877 b_Expr = nlHsVar b_RDR
1878 c_Expr = nlHsVar c_RDR
1879 f_Expr = nlHsVar f_RDR
1880 z_Expr = nlHsVar z_RDR
1881 ltTag_Expr = nlHsVar ltTag_RDR
1882 eqTag_Expr = nlHsVar eqTag_RDR
1883 gtTag_Expr = nlHsVar gtTag_RDR
1884 false_Expr = nlHsVar false_RDR
1885 true_Expr = nlHsVar true_RDR
1887 a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName
1888 a_Pat = nlVarPat a_RDR
1889 b_Pat = nlVarPat b_RDR
1890 c_Pat = nlVarPat c_RDR
1891 d_Pat = nlVarPat d_RDR
1892 f_Pat = nlVarPat f_RDR
1893 k_Pat = nlVarPat k_RDR
1894 z_Pat = nlVarPat z_RDR
1896 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1897 -- Generates Orig s RdrName, for the binding positions
1898 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
1899 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
1900 maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc
1902 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
1903 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
1905 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
1906 mkAuxBinderName parent occ_fun = mkRdrUnqual (occ_fun (nameOccName parent))
1907 -- Was: mkDerivedRdrName name occ_fun, which made an original name
1908 -- But: (a) that does not work well for standalone-deriving
1909 -- (b) an unqualified name is just fine, provided it can't clash with user code
1912 s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
1913 PrelNames, so PrelNames can't import PrimOp.
1916 primOpRdrName :: PrimOp -> RdrName
1917 primOpRdrName op = getRdrName (primOpId op)
1919 minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, leInt_RDR,
1920 tagToEnum_RDR :: RdrName
1921 minusInt_RDR = primOpRdrName IntSubOp
1922 eqInt_RDR = primOpRdrName IntEqOp
1923 ltInt_RDR = primOpRdrName IntLtOp
1924 geInt_RDR = primOpRdrName IntGeOp
1925 leInt_RDR = primOpRdrName IntLeOp
1926 tagToEnum_RDR = primOpRdrName TagToEnumOp
1928 error_RDR :: RdrName
1929 error_RDR = getRdrName eRROR_ID