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
335 ltTag_Expr gtTag_Expr))
337 tycon_data_cons = tyConDataCons tycon
338 single_con_type = isSingleton tycon_data_cons
339 (nullary_cons, nonnullary_cons)
340 | isNewTyCon tycon = ([], tyConDataCons tycon)
341 | otherwise = partition isNullarySrcDataCon tycon_data_cons
343 cmp_eq = mk_FunBind loc cmp_eq_RDR cmp_eq_match
345 | isEnumerationTyCon tycon
346 -- We know the tags are equal, so if it's an
347 -- enumeration TyCon,
348 -- then there is nothing left to do
349 -- Catch this specially to avoid warnings
350 -- about overlapping patterns from the desugarer,
351 -- and to avoid unnecessary pattern-matching
352 = [([nlWildPat,nlWildPat], eqTag_Expr)]
354 = map pats_etc nonnullary_cons ++
355 (if single_con_type then -- Omit wildcards when there's just one
356 [] -- constructor, to silence desugarer
358 [([nlWildPat, nlWildPat], default_rhs)])
360 default_rhs | null nullary_cons = -- Keep desugarer from complaining about
361 -- inexhaustive patterns
363 | otherwise = -- Some nullary constructors;
364 -- Tags are equal, no args => return EQ
367 = ([con1_pat, con2_pat],
368 nested_compare_expr tys_needed as_needed bs_needed)
370 con1_pat = nlConVarPat data_con_RDR as_needed
371 con2_pat = nlConVarPat data_con_RDR bs_needed
373 data_con_RDR = getRdrName data_con
374 con_arity = length tys_needed
375 as_needed = take con_arity as_RDRs
376 bs_needed = take con_arity bs_RDRs
377 tys_needed = dataConOrigArgTys data_con
379 nested_compare_expr [ty] [a] [b]
380 = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b)
382 nested_compare_expr (ty:tys) (a:as) (b:bs)
383 = let eq_expr = nested_compare_expr tys as bs
384 in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b)
386 -- Args always equal length
387 nested_compare_expr _ _ _ = panic "nested_compare_expr"
390 Note [Comparision of primitive types]
391 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
392 The general plan does not work well for data types like
393 data T = MkT Int# deriving( Ord )
394 The general plan defines the 'compare' method, gets (<) etc from it. But
395 that means we get silly code like:
397 (>) (I# x) (I# y) = case <# x y of
399 False -> case ==# x y of
402 We would prefer to use the (>#) primop. See also Trac #2130
406 gen_PrimOrd_binds :: DataCon -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
407 -- See Note [Comparison of primitive types]
408 gen_PrimOrd_binds data_con prim_tc
409 = (listToBag [mk_op lt_RDR lt_op, mk_op le_RDR le_op,
410 mk_op ge_RDR ge_op, mk_op gt_RDR gt_op], [])
412 mk_op op_RDR op = mk_FunBind (getSrcSpan data_con) op_RDR
413 [([apat, bpat], genOpApp a_Expr (primOpRdrName op) b_Expr)]
414 con_RDR = getRdrName data_con
415 apat = nlConVarPat con_RDR [a_RDR]
416 bpat = nlConVarPat con_RDR [b_RDR]
418 (lt_op, le_op, ge_op, gt_op)
419 | prim_tc == charPrimTyCon = (CharLtOp, CharLeOp, CharGeOp, CharGtOp)
420 | prim_tc == intPrimTyCon = (IntLtOp, IntLeOp, IntGeOp, IntGtOp)
421 | prim_tc == wordPrimTyCon = (WordLtOp, WordLeOp, WordGeOp, WordGtOp)
422 | prim_tc == addrPrimTyCon = (AddrLtOp, AddrLeOp, AddrGeOp, AddrGtOp)
423 | prim_tc == floatPrimTyCon = (FloatLtOp, FloatLeOp, FloatGeOp, FloatGtOp)
424 | prim_tc == doublePrimTyCon = (DoubleLtOp, DoubleLeOp, DoubleGeOp, DoubleGtOp)
425 | otherwise = pprPanic "Unexpected primitive tycon" (ppr prim_tc)
428 primWrapperType_maybe :: TyCon -> Maybe (DataCon, TyCon)
429 -- True of data types that are wrappers around prmitive types
430 -- data T = MkT Word#
431 -- For these we want to generate all the (<), (<=) etc operations individually
432 primWrapperType_maybe tc
433 | [con] <- tyConDataCons tc
434 , [ty] <- dataConOrigArgTys con
435 , Just (prim_tc, []) <- tcSplitTyConApp_maybe ty
436 , isPrimTyCon prim_tc
437 = Just (con, prim_tc)
442 %************************************************************************
446 %************************************************************************
448 @Enum@ can only be derived for enumeration types. For a type
450 data Foo ... = N1 | N2 | ... | Nn
453 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
454 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
457 instance ... Enum (Foo ...) where
458 succ x = toEnum (1 + fromEnum x)
459 pred x = toEnum (fromEnum x - 1)
461 toEnum i = tag2con_Foo i
463 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
467 = case con2tag_Foo a of
468 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
471 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
475 = case con2tag_Foo a of { a# ->
476 case con2tag_Foo b of { b# ->
477 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
481 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
484 gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
485 gen_Enum_binds loc tycon
486 = (method_binds, aux_binds)
488 method_binds = listToBag [
496 aux_binds = [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon]
498 occ_nm = getOccString tycon
501 = mk_easy_FunBind loc succ_RDR [a_Pat] $
502 untag_Expr tycon [(a_RDR, ah_RDR)] $
503 nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
504 nlHsVarApps intDataCon_RDR [ah_RDR]])
505 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
506 (nlHsApp (nlHsVar (tag2con_RDR tycon))
507 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
511 = mk_easy_FunBind loc pred_RDR [a_Pat] $
512 untag_Expr tycon [(a_RDR, ah_RDR)] $
513 nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
514 nlHsVarApps intDataCon_RDR [ah_RDR]])
515 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
516 (nlHsApp (nlHsVar (tag2con_RDR tycon))
517 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
518 nlHsLit (HsInt (-1))]))
521 = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
522 nlHsIf (nlHsApps and_RDR
523 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
524 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
525 (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
526 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
529 = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
530 untag_Expr tycon [(a_RDR, ah_RDR)] $
532 [nlHsVar (tag2con_RDR tycon),
533 nlHsPar (enum_from_to_Expr
534 (nlHsVarApps intDataCon_RDR [ah_RDR])
535 (nlHsVar (maxtag_RDR tycon)))]
538 = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
539 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
540 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
541 nlHsPar (enum_from_then_to_Expr
542 (nlHsVarApps intDataCon_RDR [ah_RDR])
543 (nlHsVarApps intDataCon_RDR [bh_RDR])
544 (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
545 nlHsVarApps intDataCon_RDR [bh_RDR]])
547 (nlHsVar (maxtag_RDR tycon))
551 = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
552 untag_Expr tycon [(a_RDR, ah_RDR)] $
553 (nlHsVarApps intDataCon_RDR [ah_RDR])
556 %************************************************************************
560 %************************************************************************
563 gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
564 gen_Bounded_binds loc tycon
565 | isEnumerationTyCon tycon
566 = (listToBag [ min_bound_enum, max_bound_enum ], [])
568 = ASSERT(isSingleton data_cons)
569 (listToBag [ min_bound_1con, max_bound_1con ], [])
571 data_cons = tyConDataCons tycon
573 ----- enum-flavored: ---------------------------
574 min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
575 max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
577 data_con_1 = head data_cons
578 data_con_N = last data_cons
579 data_con_1_RDR = getRdrName data_con_1
580 data_con_N_RDR = getRdrName data_con_N
582 ----- single-constructor-flavored: -------------
583 arity = dataConSourceArity data_con_1
585 min_bound_1con = mkHsVarBind loc minBound_RDR $
586 nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
587 max_bound_1con = mkHsVarBind loc maxBound_RDR $
588 nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
591 %************************************************************************
595 %************************************************************************
597 Deriving @Ix@ is only possible for enumeration types and
598 single-constructor types. We deal with them in turn.
600 For an enumeration type, e.g.,
602 data Foo ... = N1 | N2 | ... | Nn
604 things go not too differently from @Enum@:
606 instance ... Ix (Foo ...) where
608 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
612 = case (con2tag_Foo a) of { a# ->
613 case (con2tag_Foo b) of { b# ->
614 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
617 -- Generate code for unsafeIndex, becuase using index leads
618 -- to lots of redundant range tests
619 unsafeIndex c@(a, b) d
620 = case (con2tag_Foo d -# con2tag_Foo a) of
625 p_tag = con2tag_Foo c
627 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
631 = case (con2tag_Foo a) of { a_tag ->
632 case (con2tag_Foo b) of { b_tag ->
633 case (con2tag_Foo c) of { c_tag ->
634 if (c_tag >=# a_tag) then
640 (modulo suitable case-ification to handle the unlifted tags)
642 For a single-constructor type (NB: this includes all tuples), e.g.,
644 data Foo ... = MkFoo a b Int Double c c
646 we follow the scheme given in Figure~19 of the Haskell~1.2 report
650 gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
652 gen_Ix_binds loc tycon
653 | isEnumerationTyCon tycon
654 = (enum_ixes, [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon])
656 = (single_con_ixes, [GenCon2Tag tycon])
658 --------------------------------------------------------------
659 enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
662 = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
663 untag_Expr tycon [(a_RDR, ah_RDR)] $
664 untag_Expr tycon [(b_RDR, bh_RDR)] $
665 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
666 nlHsPar (enum_from_to_Expr
667 (nlHsVarApps intDataCon_RDR [ah_RDR])
668 (nlHsVarApps intDataCon_RDR [bh_RDR]))
671 = mk_easy_FunBind loc unsafeIndex_RDR
672 [noLoc (AsPat (noLoc c_RDR)
673 (nlTuplePat [a_Pat, nlWildPat] Boxed)),
675 untag_Expr tycon [(a_RDR, ah_RDR)] (
676 untag_Expr tycon [(d_RDR, dh_RDR)] (
678 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
681 (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
682 [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
687 = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
688 untag_Expr tycon [(a_RDR, ah_RDR)] (
689 untag_Expr tycon [(b_RDR, bh_RDR)] (
690 untag_Expr tycon [(c_RDR, ch_RDR)] (
691 nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
692 (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
697 --------------------------------------------------------------
699 = listToBag [single_con_range, single_con_index, single_con_inRange]
702 = case tyConSingleDataCon_maybe tycon of -- just checking...
703 Nothing -> panic "get_Ix_binds"
706 con_arity = dataConSourceArity data_con
707 data_con_RDR = getRdrName data_con
709 as_needed = take con_arity as_RDRs
710 bs_needed = take con_arity bs_RDRs
711 cs_needed = take con_arity cs_RDRs
713 con_pat xs = nlConVarPat data_con_RDR xs
714 con_expr = nlHsVarApps data_con_RDR cs_needed
716 --------------------------------------------------------------
718 = mk_easy_FunBind loc range_RDR
719 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
720 nlHsDo ListComp stmts con_expr
722 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
724 mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
725 (nlHsApp (nlHsVar range_RDR)
726 (mkLHsVarTuple [a,b]))
730 = mk_easy_FunBind loc unsafeIndex_RDR
731 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
733 -- We need to reverse the order we consider the components in
735 -- range (l,u) !! index (l,u) i == i -- when i is in range
736 -- (from http://haskell.org/onlinereport/ix.html) holds.
737 (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
739 -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
740 mk_index [] = nlHsIntLit 0
741 mk_index [(l,u,i)] = mk_one l u i
742 mk_index ((l,u,i) : rest)
747 (nlHsApp (nlHsVar unsafeRangeSize_RDR)
748 (mkLHsVarTuple [l,u]))
749 ) times_RDR (mk_index rest)
752 = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i]
756 = mk_easy_FunBind loc inRange_RDR
757 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
759 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
761 in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
764 %************************************************************************
768 %************************************************************************
778 instance Read T where
782 do x <- ReadP.step Read.readPrec
783 Symbol "%%" <- Lex.lex
784 y <- ReadP.step Read.readPrec
788 -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
789 -- Record construction binds even more tightly than application
790 do Ident "T1" <- Lex.lex
792 Ident "f1" <- Lex.lex
794 x <- ReadP.reset Read.readPrec
796 return (T1 { f1 = x }))
799 do Ident "T2" <- Lex.lexP
800 x <- ReadP.step Read.readPrec
804 readListPrec = readListPrecDefault
805 readList = readListDefault
809 gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
811 gen_Read_binds get_fixity loc tycon
812 = (listToBag [read_prec, default_readlist, default_readlistprec], [])
814 -----------------------------------------------------------------------
816 = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
819 = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
820 -----------------------------------------------------------------------
822 data_cons = tyConDataCons tycon
823 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
825 read_prec = mkHsVarBind loc readPrec_RDR
826 (nlHsApp (nlHsVar parens_RDR) read_cons)
828 read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
829 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
832 = case nullary_cons of
834 [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
835 (result_expr con [])]
836 _ -> [nlHsApp (nlHsVar choose_RDR)
837 (nlList (map mk_pair nullary_cons))]
839 mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),
842 read_non_nullary_con data_con
843 | is_infix = mk_parser infix_prec infix_stmts body
844 | is_record = mk_parser record_prec record_stmts body
845 -- Using these two lines instead allows the derived
846 -- read for infix and record bindings to read the prefix form
847 -- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body)
848 -- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
849 | otherwise = prefix_parser
851 body = result_expr data_con as_needed
852 con_str = data_con_str data_con
854 prefix_parser = mk_parser prefix_prec prefix_stmts body
857 | isSym con_str = [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"]
858 | otherwise = [bindLex (ident_pat con_str)]
861 | isSym con_str = [bindLex (symbol_pat con_str)]
862 | otherwise = [read_punc "`", bindLex (ident_pat con_str), read_punc "`"]
864 prefix_stmts -- T a b c
865 = read_prefix_con ++ read_args
867 infix_stmts -- a %% b, or a `T` b
872 record_stmts -- T { f1 = a, f2 = b }
875 ++ concat (intersperse [read_punc ","] field_stmts)
878 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
880 con_arity = dataConSourceArity data_con
881 labels = dataConFieldLabels data_con
882 dc_nm = getName data_con
883 is_infix = dataConIsInfix data_con
884 is_record = length labels > 0
885 as_needed = take con_arity as_RDRs
886 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
887 (read_a1:read_a2:_) = read_args
889 prefix_prec = appPrecedence
890 infix_prec = getPrecedence get_fixity dc_nm
891 record_prec = appPrecedence + 1 -- Record construction binds even more tightly
892 -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
894 ------------------------------------------------------------------------
896 ------------------------------------------------------------------------
897 mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
898 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b] -- prec p (do { ss ; b })
899 bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP
900 con_app con as = nlHsVarApps (getRdrName con) as -- con as
901 result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
903 punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
904 ident_pat s = nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo"
905 symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>"
907 data_con_str con = occNameString (getOccName con)
909 read_punc c = bindLex (punc_pat c)
910 read_arg a ty = ASSERT( not (isUnLiftedType ty) )
911 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
913 read_field lbl a = read_lbl lbl ++
915 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
917 -- When reading field labels we might encounter
922 read_lbl lbl | isSym lbl_str
924 bindLex (symbol_pat lbl_str),
927 = [bindLex (ident_pat lbl_str)]
929 lbl_str = occNameString (getOccName lbl)
933 %************************************************************************
937 %************************************************************************
943 data Tree a = Leaf a | Tree a :^: Tree a
945 instance (Show a) => Show (Tree a) where
947 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
949 showStr = showString "Leaf " . showsPrec (app_prec+1) m
951 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
953 showStr = showsPrec (up_prec+1) u .
955 showsPrec (up_prec+1) v
956 -- Note: right-associativity of :^: ignored
958 up_prec = 5 -- Precedence of :^:
959 app_prec = 10 -- Application has precedence one more than
960 -- the most tightly-binding operator
963 gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
965 gen_Show_binds get_fixity loc tycon
966 = (listToBag [shows_prec, show_list], [])
968 -----------------------------------------------------------------------
969 show_list = mkHsVarBind loc showList_RDR
970 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
971 -----------------------------------------------------------------------
972 shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
975 | nullary_con = -- skip the showParen junk...
976 ASSERT(null bs_needed)
977 ([nlWildPat, con_pat], mk_showString_app con_str)
980 showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
981 (nlHsPar (nested_compose_Expr show_thingies)))
983 data_con_RDR = getRdrName data_con
984 con_arity = dataConSourceArity data_con
985 bs_needed = take con_arity bs_RDRs
986 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
987 con_pat = nlConVarPat data_con_RDR bs_needed
988 nullary_con = con_arity == 0
989 labels = dataConFieldLabels data_con
990 lab_fields = length labels
991 record_syntax = lab_fields > 0
993 dc_nm = getName data_con
994 dc_occ_nm = getOccName data_con
995 con_str = occNameString dc_occ_nm
996 op_con_str = wrapOpParens con_str
997 backquote_str = wrapOpBackquotes con_str
1000 | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
1001 | record_syntax = mk_showString_app (op_con_str ++ " {") :
1002 show_record_args ++ [mk_showString_app "}"]
1003 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
1005 show_label l = mk_showString_app (nm ++ " = ")
1006 -- Note the spaces around the "=" sign. If we don't have them
1007 -- then we get Foo { x=-1 } and the "=-" parses as a single
1008 -- lexeme. Only the space after the '=' is necessary, but
1009 -- it seems tidier to have them both sides.
1011 occ_nm = getOccName l
1012 nm = wrapOpParens (occNameString occ_nm)
1014 show_args = zipWith show_arg bs_needed arg_tys
1015 (show_arg1:show_arg2:_) = show_args
1016 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
1018 -- Assumption for record syntax: no of fields == no of labelled fields
1019 -- (and in same order)
1020 show_record_args = concat $
1021 intersperse [mk_showString_app ", "] $
1022 [ [show_label lbl, arg]
1023 | (lbl,arg) <- zipEqual "gen_Show_binds"
1026 -- Generates (showsPrec p x) for argument x, but it also boxes
1027 -- the argument first if necessary. Note that this prints unboxed
1028 -- things without any '#' decorations; could change that if need be
1029 show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
1030 box_if_necy "Show" tycon (nlHsVar b) arg_ty]
1033 is_infix = dataConIsInfix data_con
1034 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1035 arg_prec | record_syntax = 0 -- Record fields don't need parens
1036 | otherwise = con_prec_plus_one
1038 wrapOpParens :: String -> String
1039 wrapOpParens s | isSym s = '(' : s ++ ")"
1042 wrapOpBackquotes :: String -> String
1043 wrapOpBackquotes s | isSym s = s
1044 | otherwise = '`' : s ++ "`"
1046 isSym :: String -> Bool
1048 isSym (c : _) = startsVarSym c || startsConSym c
1050 mk_showString_app :: String -> LHsExpr RdrName
1051 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1055 getPrec :: Bool -> FixityEnv -> Name -> Integer
1056 getPrec is_infix get_fixity nm
1057 | not is_infix = appPrecedence
1058 | otherwise = getPrecedence get_fixity nm
1060 appPrecedence :: Integer
1061 appPrecedence = fromIntegral maxPrecedence + 1
1062 -- One more than the precedence of the most
1063 -- tightly-binding operator
1065 getPrecedence :: FixityEnv -> Name -> Integer
1066 getPrecedence get_fixity nm
1067 = case lookupFixity get_fixity nm of
1068 Fixity x _assoc -> fromIntegral x
1069 -- NB: the Report says that associativity is not taken
1070 -- into account for either Read or Show; hence we
1071 -- ignore associativity here
1075 %************************************************************************
1077 \subsection{Typeable}
1079 %************************************************************************
1087 instance Typeable2 T where
1088 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1090 We are passed the Typeable2 class as well as T
1093 gen_Typeable_binds :: SrcSpan -> TyCon -> LHsBinds RdrName
1094 gen_Typeable_binds loc tycon
1097 (mk_typeOf_RDR tycon) -- Name of appropriate type0f function
1099 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1101 tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
1103 mk_typeOf_RDR :: TyCon -> RdrName
1104 -- Use the arity of the TyCon to make the right typeOfn function
1105 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1107 arity = tyConArity tycon
1108 suffix | arity == 0 = ""
1109 | otherwise = show arity
1114 %************************************************************************
1118 %************************************************************************
1122 data T a b = T1 a b | T2
1126 $cT1 = mkDataCon $dT "T1" Prefix
1127 $cT2 = mkDataCon $dT "T2" Prefix
1128 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1129 -- the [] is for field labels.
1131 instance (Data a, Data b) => Data (T a b) where
1132 gfoldl k z (T1 a b) = z T `k` a `k` b
1133 gfoldl k z T2 = z T2
1134 -- ToDo: add gmapT,Q,M, gfoldr
1136 gunfold k z c = case conIndex c of
1137 I# 1# -> k (k (z T1))
1140 toConstr (T1 _ _) = $cT1
1145 dataCast1 = gcast1 -- If T :: * -> *
1146 dataCast2 = gcast2 -- if T :: * -> * -> *
1150 gen_Data_binds :: SrcSpan
1152 -> (LHsBinds RdrName, -- The method bindings
1153 DerivAuxBinds) -- Auxiliary bindings
1154 gen_Data_binds loc tycon
1155 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
1156 `unionBags` gcast_binds,
1157 -- Auxiliary definitions: the data type and constructors
1158 MkTyCon tycon : map MkDataCon data_cons)
1160 data_cons = tyConDataCons tycon
1161 n_cons = length data_cons
1162 one_constr = n_cons == 1
1165 gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons)
1166 gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1167 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1170 con_name = getRdrName con
1171 as_needed = take (dataConSourceArity con) as_RDRs
1172 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1174 ------------ gunfold
1175 gunfold_bind = mk_FunBind loc
1177 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1181 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1182 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1183 (map gunfold_alt data_cons)
1185 gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1186 mk_unfold_rhs dc = foldr nlHsApp
1187 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1188 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1190 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1191 -- redundant test, and annoying warning
1192 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1193 | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1197 ------------ toConstr
1198 toCon_bind = mk_FunBind loc toConstr_RDR (map to_con_eqn data_cons)
1199 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1201 ------------ dataTypeOf
1202 dataTypeOf_bind = mk_easy_FunBind
1206 (nlHsVar (mk_data_type_name tycon))
1208 ------------ gcast1/2
1209 tycon_kind = tyConKind tycon
1210 gcast_binds | tycon_kind `eqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR
1211 | tycon_kind `eqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
1212 | otherwise = emptyBag
1213 mk_gcast dataCast_RDR gcast_RDR
1214 = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
1215 (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
1218 kind1, kind2 :: Kind
1219 kind1 = liftedTypeKind `mkArrowKind` liftedTypeKind
1220 kind2 = liftedTypeKind `mkArrowKind` kind1
1222 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
1223 mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
1224 dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR :: RdrName
1225 gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
1226 gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
1227 toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
1228 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1229 dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1")
1230 dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2")
1231 gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1")
1232 gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2")
1233 mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
1234 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1235 conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
1236 prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix")
1237 infix_RDR = dataQual_RDR gENERICS (fsLit "Infix")
1242 %************************************************************************
1246 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1249 %************************************************************************
1253 data T a = T1 Int a | T2 (T a)
1255 We generate the instance:
1257 instance Functor T where
1258 fmap f (T1 b1 a) = T1 b1 (f a)
1259 fmap f (T2 ta) = T2 (fmap f ta)
1261 Notice that we don't simply apply 'fmap' to the constructor arguments.
1263 - Do nothing to an argument whose type doesn't mention 'a'
1264 - Apply 'f' to an argument of type 'a'
1265 - Apply 'fmap f' to other arguments
1266 That's why we have to recurse deeply into the constructor argument types,
1267 rather than just one level, as we typically do.
1269 What about types with more than one type parameter? In general, we only
1270 derive Functor for the last position:
1272 data S a b = S1 [b] | S2 (a, T a b)
1273 instance Functor (S a) where
1274 fmap f (S1 bs) = S1 (fmap f bs)
1275 fmap f (S2 (p,q)) = S2 (a, fmap f q)
1277 However, we have special cases for
1281 More formally, we write the derivation of fmap code over type variable
1282 'a for type 'b as ($fmap 'a 'b). In this general notation the derived
1285 instance Functor T where
1286 fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
1287 fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1)
1289 $(fmap 'a 'b) x = x -- when b does not contain a
1290 $(fmap 'a 'a) x = f x
1291 $(fmap 'a '(b1,b2)) x = case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
1292 $(fmap 'a '(T b1 b2)) x = fmap $(fmap 'a 'b2) x -- when a only occurs in the last parameter, b2
1293 $(fmap 'a '(b -> c)) x = \b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
1295 For functions, the type parameter 'a can occur in a contravariant position,
1296 which means we need to derive a function like:
1298 cofmap :: (a -> b) -> (f b -> f a)
1300 This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
1302 $(cofmap 'a 'b) x = x -- when b does not contain a
1303 $(cofmap 'a 'a) x = error "type variable in contravariant position"
1304 $(cofmap 'a '(b1,b2)) x = case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
1305 $(cofmap 'a '[b]) x = map $(cofmap 'a 'b) x
1306 $(cofmap 'a '(T b1 b2)) x = fmap $(cofmap 'a 'b2) x -- when a only occurs in the last parameter, b2
1307 $(cofmap 'a '(b -> c)) x = \b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
1310 gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1311 gen_Functor_binds loc tycon
1312 = (unitBag fmap_bind, [])
1314 data_cons = tyConDataCons tycon
1316 fmap_bind = L loc $ mkFunBind (L loc fmap_RDR) (map fmap_eqn data_cons)
1317 fmap_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1319 parts = foldDataConArgs ft_fmap con
1321 ft_fmap :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1322 -- Tricky higher order type; I can't say I fully understand this code :-(
1323 ft_fmap = FT { ft_triv = \x -> return x -- fmap f x = x
1324 , ft_var = \x -> return (nlHsApp f_Expr x) -- fmap f x = f x
1325 , ft_fun = \g h x -> mkSimpleLam (\b -> h =<< (nlHsApp x `fmap` g b))
1326 -- fmap f x = \b -> h (x (g b))
1327 , ft_tup = mkSimpleTupleCase match_for_con -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
1328 , ft_ty_app = \_ g x -> do gg <- mkSimpleLam g -- fmap f x = fmap g x
1329 return $ nlHsApps fmap_RDR [gg,x]
1330 , ft_forall = \_ g x -> g x
1331 , ft_bad_app = panic "in other argument"
1332 , ft_co_var = panic "contravariant" }
1334 match_for_con = mkSimpleConMatch $
1335 \con_name xsM -> do xs <- sequence xsM
1336 return (nlHsApps con_name xs) -- Con (g1 v1) (g2 v2) ..
1339 Utility functions related to Functor deriving.
1341 Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
1342 This function works like a fold: it makes a value of type 'a' in a bottom up way.
1345 -- Generic traversal for Functor deriving
1346 data FFoldType a -- Describes how to fold over a Type in a functor like way
1347 = FT { ft_triv :: a -- Does not contain variable
1348 , ft_var :: a -- The variable itself
1349 , ft_co_var :: a -- The variable itself, contravariantly
1350 , ft_fun :: a -> a -> a -- Function type
1351 , ft_tup :: Boxity -> [a] -> a -- Tuple type
1352 , ft_ty_app :: Type -> a -> a -- Type app, variable only in last argument
1353 , ft_bad_app :: a -- Type app, variable other than in last argument
1354 , ft_forall :: TcTyVar -> a -> a -- Forall type
1357 functorLikeTraverse :: TyVar -- ^ Variable to look for
1358 -> FFoldType a -- ^ How to fold
1359 -> Type -- ^ Type to process
1361 functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar
1362 , ft_co_var = caseCoVar, ft_fun = caseFun
1363 , ft_tup = caseTuple, ft_ty_app = caseTyApp
1364 , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
1367 where -- go returns (result of type a, does type contain var)
1368 go co ty | Just ty' <- coreView ty = go co ty'
1369 go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True)
1370 go co (FunTy (PredTy _) b) = go co b
1371 go co (FunTy x y) | xc || yc = (caseFun xr yr,True)
1372 where (xr,xc) = go (not co) x
1374 go co (AppTy x y) | xc = (caseWrongArg, True)
1375 | yc = (caseTyApp x yr, True)
1376 where (_, xc) = go co x
1378 go co ty@(TyConApp con args)
1379 | isTupleTyCon con = (caseTuple (tupleTyConBoxity con) xrs,True)
1380 | null args = (caseTrivial,False) -- T
1381 | or (init xcs) = (caseWrongArg,True) -- T (..var..) ty
1382 | last xcs = -- T (..no var..) ty
1383 (caseTyApp (fst (splitAppTy ty)) (last xrs),True)
1384 where (xrs,xcs) = unzip (map (go co) args)
1385 go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True)
1386 where (xr,xc) = go co x
1387 go _ _ = (caseTrivial,False)
1389 -- Return all syntactic subterms of ty that contain var somewhere
1390 -- These are the things that should appear in instance constraints
1391 deepSubtypesContaining :: TyVar -> Type -> [TcType]
1392 deepSubtypesContaining tv
1393 = functorLikeTraverse tv
1396 , ft_fun = (++), ft_tup = \_ xs -> concat xs
1398 , ft_bad_app = panic "in other argument"
1399 , ft_co_var = panic "contravariant"
1400 , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyVarsOfType) xs })
1403 foldDataConArgs :: FFoldType a -> DataCon -> [a]
1404 -- Fold over the arguments of the datacon
1405 foldDataConArgs ft con
1406 = map (functorLikeTraverse tv ft) (dataConOrigArgTys con)
1408 tv = last (dataConUnivTyVars con)
1409 -- Argument to derive for, 'a in the above description
1410 -- The validity checks have ensured that con is
1411 -- a vanilla data constructor
1413 -- Make a HsLam using a fresh variable from a State monad
1414 mkSimpleLam :: (LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1415 -- (mkSimpleLam fn) returns (\x. fn(x))
1416 mkSimpleLam lam = do
1419 body <- lam (nlHsVar n)
1420 return (mkHsLam [nlVarPat n] body)
1422 mkSimpleLam2 :: (LHsExpr id -> LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1423 mkSimpleLam2 lam = do
1424 (n1:n2:names) <- get
1426 body <- lam (nlHsVar n1) (nlHsVar n2)
1427 return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
1429 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
1430 mkSimpleConMatch :: Monad m => (RdrName -> [a] -> m (LHsExpr RdrName)) -> [LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName)
1431 mkSimpleConMatch fold extra_pats con insides = do
1432 let con_name = getRdrName con
1433 let vars_needed = takeList insides as_RDRs
1434 let pat = nlConVarPat con_name vars_needed
1435 rhs <- fold con_name (zipWith ($) insides (map nlHsVar vars_needed))
1436 return $ mkMatch (extra_pats ++ [pat]) rhs emptyLocalBinds
1438 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
1439 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName))
1440 -> Boxity -> [LHsExpr RdrName -> a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
1441 mkSimpleTupleCase match_for_con boxity insides x = do
1442 let con = tupleCon boxity (length insides)
1443 match <- match_for_con [] con insides
1444 return $ nlHsCase x [match]
1448 %************************************************************************
1452 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1455 %************************************************************************
1457 Deriving Foldable instances works the same way as Functor instances,
1458 only Foldable instances are not possible for function types at all.
1459 Here the derived instance for the type T above is:
1461 instance Foldable T where
1462 foldr f z (T1 x1 x2 x3) = $(foldr 'a 'b1) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a 'b2) x3 z ) )
1466 $(foldr 'a 'b) x z = z -- when b does not contain a
1467 $(foldr 'a 'a) x z = f x z
1468 $(foldr 'a '(b1,b2)) x z = case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
1469 $(foldr 'a '(T b1 b2)) x z = foldr $(foldr 'a 'b2) x z -- when a only occurs in the last parameter, b2
1471 Note that the arguments to the real foldr function are the wrong way around,
1472 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
1475 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1476 gen_Foldable_binds loc tycon
1477 = (unitBag foldr_bind, [])
1479 data_cons = tyConDataCons tycon
1481 foldr_bind = L loc $ mkFunBind (L loc foldable_foldr_RDR) (map foldr_eqn data_cons)
1482 foldr_eqn con = evalState (match_for_con z_Expr [f_Pat,z_Pat] con parts) bs_RDRs
1484 parts = foldDataConArgs ft_foldr con
1486 ft_foldr :: FFoldType (LHsExpr RdrName -> LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1487 ft_foldr = FT { ft_triv = \_ z -> return z -- foldr f z x = z
1488 , ft_var = \x z -> return (nlHsApps f_RDR [x,z]) -- foldr f z x = f x z
1489 , ft_tup = \b gs x z -> mkSimpleTupleCase (match_for_con z) b gs x
1490 , ft_ty_app = \_ g x z -> do gg <- mkSimpleLam2 g -- foldr f z x = foldr (\xx zz -> g xx zz) z x
1491 return $ nlHsApps foldable_foldr_RDR [gg,z,x]
1492 , ft_forall = \_ g x z -> g x z
1493 , ft_co_var = panic "covariant"
1494 , ft_fun = panic "function"
1495 , ft_bad_app = panic "in other argument" }
1497 match_for_con z = mkSimpleConMatch (\_con_name -> foldrM ($) z) -- g1 v1 (g2 v2 (.. z))
1501 %************************************************************************
1503 Traversable instances
1505 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1507 %************************************************************************
1509 Again, Traversable is much like Functor and Foldable.
1513 $(traverse 'a 'b) x = pure x -- when b does not contain a
1514 $(traverse 'a 'a) x = f x
1515 $(traverse 'a '(b1,b2)) x = case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
1516 $(traverse 'a '(T b1 b2)) x = traverse $(traverse 'a 'b2) x -- when a only occurs in the last parameter, b2
1518 Note that the generated code is not as efficient as it could be. For instance:
1520 data T a = T Int a deriving Traversable
1522 gives the function: traverse f (T x y) = T <$> pure x <*> f y
1523 instead of: traverse f (T x y) = T x <$> f y
1526 gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1527 gen_Traversable_binds loc tycon
1528 = (unitBag traverse_bind, [])
1530 data_cons = tyConDataCons tycon
1532 traverse_bind = L loc $ mkFunBind (L loc traverse_RDR) (map traverse_eqn data_cons)
1533 traverse_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1535 parts = foldDataConArgs ft_trav con
1538 ft_trav :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1539 ft_trav = FT { ft_triv = \x -> return (nlHsApps pure_RDR [x]) -- traverse f x = pure x
1540 , ft_var = \x -> return (nlHsApps f_RDR [x]) -- travese f x = f x
1541 , ft_tup = mkSimpleTupleCase match_for_con -- travese f x z = case x of (a1,a2,..) ->
1542 -- (,,) <$> g1 a1 <*> g2 a2 <*> ..
1543 , ft_ty_app = \_ g x -> do gg <- mkSimpleLam g -- travese f x = travese (\xx -> g xx) x
1544 return $ nlHsApps traverse_RDR [gg,x]
1545 , ft_forall = \_ g x -> g x
1546 , ft_co_var = panic "covariant"
1547 , ft_fun = panic "function"
1548 , ft_bad_app = panic "in other argument" }
1550 match_for_con = mkSimpleConMatch $
1551 \con_name xsM -> do xs <- sequence xsM
1552 return (mkApCon (nlHsVar con_name) xs)
1554 -- ((Con <$> x1) <*> x2) <*> ..
1555 mkApCon con [] = nlHsApps pure_RDR [con]
1556 mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
1557 where appAp x y = nlHsApps ap_RDR [x,y]
1562 %************************************************************************
1564 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1566 %************************************************************************
1571 con2tag_Foo :: Foo ... -> Int#
1572 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1573 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1576 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1580 genAuxBind :: SrcSpan -> DerivAuxBind -> LHsBind RdrName
1581 genAuxBind loc (GenCon2Tag tycon)
1582 | lots_of_constructors
1583 = mk_FunBind loc rdr_name [([], get_tag_rhs)]
1586 = mk_FunBind loc rdr_name (map mk_stuff (tyConDataCons tycon))
1589 rdr_name = con2tag_RDR tycon
1591 tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1592 -- We can't use gerRdrName because that makes an Exact RdrName
1593 -- and we can't put them in the LocalRdrEnv
1595 -- Give a signature to the bound variable, so
1596 -- that the case expression generated by getTag is
1597 -- monomorphic. In the push-enter model we get better code.
1598 get_tag_rhs = L loc $ ExprWithTySig
1599 (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1600 (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1601 (noLoc (mkExplicitHsForAllTy (userHsTyVarBndrs (map noLoc tvs))
1602 (noLoc []) con2tag_ty))
1604 con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
1606 nlHsTyVar (getRdrName intPrimTyCon)
1608 lots_of_constructors = tyConFamilySize tycon > 8
1609 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1610 -- but we don't do vectored returns any more.
1612 mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1613 mk_stuff con = ([nlWildConPat con],
1614 nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1616 genAuxBind loc (GenTag2Con tycon)
1617 = mk_FunBind loc rdr_name
1618 [([nlConVarPat intDataCon_RDR [a_RDR]],
1619 noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1620 (nlHsTyVar (getRdrName tycon))))]
1622 rdr_name = tag2con_RDR tycon
1624 genAuxBind loc (GenMaxTag tycon)
1625 = mkHsVarBind loc rdr_name
1626 (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1628 rdr_name = maxtag_RDR tycon
1629 max_tag = case (tyConDataCons tycon) of
1630 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1632 genAuxBind loc (MkTyCon tycon) -- $dT
1633 = mkHsVarBind loc (mk_data_type_name tycon)
1634 ( nlHsVar mkDataType_RDR
1635 `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
1636 `nlHsApp` nlList constrs )
1638 constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
1640 genAuxBind loc (MkDataCon dc) -- $cT1 etc
1641 = mkHsVarBind loc (mk_constr_name dc)
1642 (nlHsApps mkConstr_RDR constr_args)
1645 = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1646 nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
1647 nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1648 nlList labels, -- Field labels
1649 nlHsVar fixity] -- Fixity
1651 labels = map (nlHsLit . mkHsString . getOccString)
1652 (dataConFieldLabels dc)
1653 dc_occ = getOccName dc
1654 is_infix = isDataSymOcc dc_occ
1655 fixity | is_infix = infix_RDR
1656 | otherwise = prefix_RDR
1658 mk_data_type_name :: TyCon -> RdrName -- "$tT"
1659 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
1661 mk_constr_name :: DataCon -> RdrName -- "$cC"
1662 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
1665 %************************************************************************
1667 \subsection{Utility bits for generating bindings}
1669 %************************************************************************
1672 ToDo: Better SrcLocs.
1676 LHsExpr RdrName -- What to do for equality
1677 -> LHsExpr RdrName -> LHsExpr RdrName
1679 careful_compare_Case :: -- checks for primitive types...
1680 TyCon -- The tycon we are deriving for
1682 -> LHsExpr RdrName -- What to do for equality
1683 -> LHsExpr RdrName -> LHsExpr RdrName
1686 cmp_eq_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1687 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1688 -- Was: compare_gen_Case cmp_eq_RDR
1690 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1691 = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1692 compare_gen_Case eq a b -- General case
1693 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1694 [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1695 mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1696 mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1698 careful_compare_Case tycon ty eq a b
1699 | not (isUnLiftedType ty)
1700 = compare_gen_Case eq a b
1701 | otherwise -- We have to do something special for primitive things...
1702 = nlHsIf (genOpApp a relevant_lt_op b) -- Test (<) first, not (==), becuase the latter
1703 ltTag_Expr -- is true less often, so putting it first would
1704 -- mean more tests (dynamically)
1705 (nlHsIf (genOpApp a relevant_eq_op b) eq gtTag_Expr)
1707 relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1708 relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1711 box_if_necy :: String -- The class involved
1712 -> TyCon -- The tycon involved
1713 -> LHsExpr RdrName -- The argument
1714 -> Type -- The argument type
1715 -> LHsExpr RdrName -- Boxed version of the arg
1716 box_if_necy cls_str tycon arg arg_ty
1717 | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1720 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1722 assoc_ty_id :: String -- The class involved
1723 -> TyCon -- The tycon involved
1724 -> [(Type,a)] -- The table
1726 -> a -- The result of the lookup
1727 assoc_ty_id cls_str _ tbl ty
1728 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1729 text "for primitive type" <+> ppr ty)
1730 | otherwise = head res
1732 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1734 eq_op_tbl :: [(Type, PrimOp)]
1736 [(charPrimTy, CharEqOp)
1737 ,(intPrimTy, IntEqOp)
1738 ,(wordPrimTy, WordEqOp)
1739 ,(addrPrimTy, AddrEqOp)
1740 ,(floatPrimTy, FloatEqOp)
1741 ,(doublePrimTy, DoubleEqOp)
1744 lt_op_tbl :: [(Type, PrimOp)]
1746 [(charPrimTy, CharLtOp)
1747 ,(intPrimTy, IntLtOp)
1748 ,(wordPrimTy, WordLtOp)
1749 ,(addrPrimTy, AddrLtOp)
1750 ,(floatPrimTy, FloatLtOp)
1751 ,(doublePrimTy, DoubleLtOp)
1754 box_con_tbl :: [(Type, RdrName)]
1756 [(charPrimTy, getRdrName charDataCon)
1757 ,(intPrimTy, getRdrName intDataCon)
1758 ,(wordPrimTy, wordDataCon_RDR)
1759 ,(floatPrimTy, getRdrName floatDataCon)
1760 ,(doublePrimTy, getRdrName doubleDataCon)
1763 -----------------------------------------------------------------------
1765 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1766 and_Expr a b = genOpApp a and_RDR b
1768 -----------------------------------------------------------------------
1770 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1771 eq_Expr tycon ty a b = genOpApp a eq_op b
1774 | not (isUnLiftedType ty) = eq_RDR
1775 | otherwise = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1776 -- we have to do something special for primitive things...
1780 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1781 untag_Expr _ [] expr = expr
1782 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1783 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1784 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1786 cmp_tags_Expr :: RdrName -- Comparison op
1787 -> RdrName -> RdrName -- Things to compare
1788 -> LHsExpr RdrName -- What to return if true
1789 -> LHsExpr RdrName -- What to return if false
1792 cmp_tags_Expr op a b true_case false_case
1793 = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1796 :: LHsExpr RdrName -> LHsExpr RdrName
1798 enum_from_then_to_Expr
1799 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1802 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1803 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1806 :: LHsExpr RdrName -> LHsExpr RdrName
1809 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1811 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1813 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
1814 nested_compose_Expr [e] = parenify e
1815 nested_compose_Expr (e:es)
1816 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1818 -- impossible_Expr is used in case RHSs that should never happen.
1819 -- We generate these to keep the desugarer from complaining that they *might* happen!
1820 impossible_Expr :: LHsExpr RdrName
1821 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1823 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1824 -- method. It is currently only used by Enum.{succ,pred}
1825 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
1826 illegal_Expr meth tp msg =
1827 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1829 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1830 -- to include the value of a_RDR in the error string.
1831 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
1832 illegal_toEnum_tag tp maxtag =
1833 nlHsApp (nlHsVar error_RDR)
1834 (nlHsApp (nlHsApp (nlHsVar append_RDR)
1835 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1836 (nlHsApp (nlHsApp (nlHsApp
1837 (nlHsVar showsPrec_RDR)
1841 (nlHsVar append_RDR)
1842 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1843 (nlHsApp (nlHsApp (nlHsApp
1844 (nlHsVar showsPrec_RDR)
1847 (nlHsLit (mkHsString ")"))))))
1849 parenify :: LHsExpr RdrName -> LHsExpr RdrName
1850 parenify e@(L _ (HsVar _)) = e
1851 parenify e = mkHsPar e
1853 -- genOpApp wraps brackets round the operator application, so that the
1854 -- renamer won't subsequently try to re-associate it.
1855 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1856 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1860 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR,
1861 cmp_eq_RDR :: RdrName
1862 a_RDR = mkVarUnqual (fsLit "a")
1863 b_RDR = mkVarUnqual (fsLit "b")
1864 c_RDR = mkVarUnqual (fsLit "c")
1865 d_RDR = mkVarUnqual (fsLit "d")
1866 f_RDR = mkVarUnqual (fsLit "f")
1867 k_RDR = mkVarUnqual (fsLit "k")
1868 z_RDR = mkVarUnqual (fsLit "z")
1869 ah_RDR = mkVarUnqual (fsLit "a#")
1870 bh_RDR = mkVarUnqual (fsLit "b#")
1871 ch_RDR = mkVarUnqual (fsLit "c#")
1872 dh_RDR = mkVarUnqual (fsLit "d#")
1873 cmp_eq_RDR = mkVarUnqual (fsLit "cmp_eq")
1875 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
1876 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1877 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1878 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1880 a_Expr, b_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
1881 false_Expr, true_Expr :: LHsExpr RdrName
1882 a_Expr = nlHsVar a_RDR
1883 b_Expr = nlHsVar b_RDR
1884 c_Expr = nlHsVar c_RDR
1885 f_Expr = nlHsVar f_RDR
1886 z_Expr = nlHsVar z_RDR
1887 ltTag_Expr = nlHsVar ltTag_RDR
1888 eqTag_Expr = nlHsVar eqTag_RDR
1889 gtTag_Expr = nlHsVar gtTag_RDR
1890 false_Expr = nlHsVar false_RDR
1891 true_Expr = nlHsVar true_RDR
1893 a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName
1894 a_Pat = nlVarPat a_RDR
1895 b_Pat = nlVarPat b_RDR
1896 c_Pat = nlVarPat c_RDR
1897 d_Pat = nlVarPat d_RDR
1898 f_Pat = nlVarPat f_RDR
1899 k_Pat = nlVarPat k_RDR
1900 z_Pat = nlVarPat z_RDR
1902 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1903 -- Generates Orig s RdrName, for the binding positions
1904 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
1905 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
1906 maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc
1908 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
1909 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
1911 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
1912 mkAuxBinderName parent occ_fun = mkRdrUnqual (occ_fun (nameOccName parent))
1913 -- Was: mkDerivedRdrName name occ_fun, which made an original name
1914 -- But: (a) that does not work well for standalone-deriving
1915 -- (b) an unqualified name is just fine, provided it can't clash with user code
1918 s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
1919 PrelNames, so PrelNames can't import PrimOp.
1922 primOpRdrName :: PrimOp -> RdrName
1923 primOpRdrName op = getRdrName (primOpId op)
1925 minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, leInt_RDR,
1926 tagToEnum_RDR :: RdrName
1927 minusInt_RDR = primOpRdrName IntSubOp
1928 eqInt_RDR = primOpRdrName IntEqOp
1929 ltInt_RDR = primOpRdrName IntLtOp
1930 geInt_RDR = primOpRdrName IntGeOp
1931 leInt_RDR = primOpRdrName IntLeOp
1932 tagToEnum_RDR = primOpRdrName TagToEnumOp
1934 error_RDR :: RdrName
1935 error_RDR = getRdrName eRROR_ID