2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcGenDeriv]{Generating derived instance declarations}
6 This module is nominally ``subordinate'' to @TcDeriv@, which is the
7 ``official'' interface to deriving-related things.
9 This is where we do all the grimy bindings' generation.
20 gen_tag_n_con_monobind,
22 con2tag_RDR, tag2con_RDR, maxtag_RDR,
27 #include "HsVersions.h"
29 import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..),
30 Match(..), GRHSs(..), Stmt(..), HsLit(..),
31 HsBinds(..), StmtCtxt(..), HsType(..),
32 unguardedRHS, mkSimpleMatch
34 import RdrHsSyn ( mkOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
35 import RdrName ( RdrName, mkSrcUnqual )
36 import RnMonad ( Fixities )
37 import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..) )
38 import FieldLabel ( fieldLabelName )
39 import DataCon ( isNullaryDataCon, dataConTag,
40 dataConRawArgTys, fIRST_TAG,
43 import Name ( getOccString, getOccName, getSrcLoc, occNameString,
44 occNameUserString, nameRdrName, varName,
45 OccName, Name, NamedThing(..), NameSpace,
46 isDataSymOcc, isSymOcc
49 import PrimOp ( PrimOp(..) )
50 import PrelInfo -- Lots of RdrNames
51 import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
52 import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
53 maybeTyConSingleCon, tyConFamilySize
55 import Type ( isUnLiftedType, isUnboxedType, Type )
56 import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
57 floatPrimTy, doublePrimTy
59 import Util ( mapAccumL, zipEqual, zipWithEqual,
60 zipWith3Equal, nOfThem )
61 import Panic ( panic, assertPanic )
62 import Maybes ( maybeToBool, assocMaybe )
64 import List ( partition, intersperse )
65 import Char ( isAlpha )
68 %************************************************************************
70 \subsection{Generating code, by derivable class}
72 %************************************************************************
74 %************************************************************************
76 \subsubsection{Generating @Eq@ instance declarations}
78 %************************************************************************
80 Here are the heuristics for the code we generate for @Eq@:
83 Let's assume we have a data type with some (possibly zero) nullary
84 data constructors and some ordinary, non-nullary ones (the rest,
85 also possibly zero of them). Here's an example, with both \tr{N}ullary
86 and \tr{O}rdinary data cons.
88 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
92 For the ordinary constructors (if any), we emit clauses to do The
96 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
97 (==) (O2 a1) (O2 a2) = a1 == a2
98 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
101 Note: if we're comparing unboxed things, e.g., if \tr{a1} and
102 \tr{a2} are \tr{Float#}s, then we have to generate
104 case (a1 `eqFloat#` a2) of
107 for that particular test.
110 If there are any nullary constructors, we emit a catch-all clause of
114 (==) a b = case (con2tag_Foo a) of { a# ->
115 case (con2tag_Foo b) of { b# ->
116 case (a# ==# b#) of {
121 If there aren't any nullary constructors, we emit a simpler
128 For the @(/=)@ method, we normally just use the default method.
130 If the type is an enumeration type, we could/may/should? generate
131 special code that calls @con2tag_Foo@, much like for @(==)@ shown
135 We thought about doing this: If we're also deriving @Ord@ for this
138 instance ... Eq (Foo ...) where
139 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
140 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
142 However, that requires that \tr{Ord <whatever>} was put in the context
143 for the instance decl, which it probably wasn't, so the decls
144 produced don't get through the typechecker.
148 deriveEq :: RdrName -- Class
149 -> RdrName -- Type constructor
150 -> [ (RdrName, [RdrType]) ] -- Constructors
151 -> (RdrContext, -- Context for the inst decl
152 [RdrBind], -- Binds in the inst decl
153 [RdrBind]) -- Extra value bindings outside
155 deriveEq clas tycon constrs
156 = (context, [eq_bind, ne_bind], [])
158 context = [(clas, [ty]) | (_, tys) <- constrs, ty <- tys]
161 (nullary_cons, non_nullary_cons) = partition is_nullary constrs
162 is_nullary (_, args) = null args
165 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
169 tycon_loc = getSrcLoc tycon
170 (nullary_cons, nonnullary_cons)
171 | isNewTyCon tycon = ([], tyConDataCons tycon)
172 | otherwise = partition isNullaryDataCon (tyConDataCons tycon)
175 = if (null nullary_cons) then
176 case maybeTyConSingleCon tycon of
178 Nothing -> -- if cons don't match, then False
179 [([wildPat, wildPat], false_Expr)]
180 else -- calc. and compare the tags
182 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
183 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR true_Expr false_Expr))]
185 mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
187 mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
188 HsApp (HsVar not_RDR) (HsPar (mk_easy_App eq_RDR [a_RDR, b_RDR])))
190 ------------------------------------------------------------------
193 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
194 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
196 data_con_RDR = qual_orig_name 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 = dataConRawArgTys 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 = HsPar (eq_Expr ty (HsVar a) (HsVar b))
211 %************************************************************************
213 \subsubsection{Generating @Ord@ instance declarations}
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 unboxed 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 :: TyCon -> RdrNameMonoBinds
311 = compare -- `AndMonoBinds` compare
312 -- The default declaration in PrelBase handles this
314 tycon_loc = getSrcLoc tycon
315 --------------------------------------------------------------------
316 compare = mk_easy_FunMonoBind tycon_loc compare_RDR
319 (if maybeToBool (maybeTyConSingleCon tycon) then
321 -- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
322 -- Wierd. Was: case (cmp a b) of { LT -> LT; EQ -> EQ; GT -> GT }
324 cmp_eq_Expr a_Expr b_Expr
326 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
327 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR
328 -- True case; they are equal
329 -- If an enumeration type we are done; else
330 -- recursively compare their components
331 (if isEnumerationTyCon tycon then
334 -- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
336 cmp_eq_Expr a_Expr b_Expr
338 -- False case; they aren't equal
339 -- So we need to do a less-than comparison on the tags
340 (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
342 tycon_data_cons = tyConDataCons tycon
343 (nullary_cons, nonnullary_cons)
344 | isNewTyCon tycon = ([], tyConDataCons tycon)
345 | otherwise = partition isNullaryDataCon tycon_data_cons
348 mk_FunMonoBind tycon_loc
350 (if null nonnullary_cons && (length nullary_cons == 1) then
351 -- catch this specially to avoid warnings
352 -- about overlapping patterns from the desugarer.
354 data_con = head nullary_cons
355 data_con_RDR = qual_orig_name data_con
356 pat = ConPatIn data_con_RDR []
358 [([pat,pat], eqTag_Expr)]
360 map pats_etc nonnullary_cons ++
361 -- leave out wildcards to silence desugarer.
362 (if length tycon_data_cons == 1 then
365 [([WildPatIn, WildPatIn], default_rhs)]))
368 = ([con1_pat, con2_pat],
369 nested_compare_expr tys_needed as_needed bs_needed)
371 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
372 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
374 data_con_RDR = qual_orig_name data_con
375 con_arity = length tys_needed
376 as_needed = take con_arity as_RDRs
377 bs_needed = take con_arity bs_RDRs
378 tys_needed = dataConRawArgTys data_con
380 nested_compare_expr [ty] [a] [b]
381 = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
383 nested_compare_expr (ty:tys) (a:as) (b:bs)
384 = let eq_expr = nested_compare_expr tys as bs
385 in careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
387 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
388 -- inexhaustive patterns
389 | otherwise = eqTag_Expr -- Some nullary constructors;
390 -- Tags are equal, no args => return EQ
391 --------------------------------------------------------------------
393 {- Not necessary: the default decls in PrelBase handle these
395 defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
397 lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] (
398 compare_Case true_Expr false_Expr false_Expr a_Expr b_Expr)
399 le = mk_easy_FunMonoBind mkGeneratedSrcLoc le_RDR [a_Pat, b_Pat] [] (
400 compare_Case true_Expr true_Expr false_Expr a_Expr b_Expr)
401 ge = mk_easy_FunMonoBind mkGeneratedSrcLoc ge_RDR [a_Pat, b_Pat] [] (
402 compare_Case false_Expr true_Expr true_Expr a_Expr b_Expr)
403 gt = mk_easy_FunMonoBind mkGeneratedSrcLoc gt_RDR [a_Pat, b_Pat] [] (
404 compare_Case false_Expr false_Expr true_Expr a_Expr b_Expr)
406 max_ = mk_easy_FunMonoBind mkGeneratedSrcLoc max_RDR [a_Pat, b_Pat] [] (
407 compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
408 min_ = mk_easy_FunMonoBind mkGeneratedSrcLoc min_RDR [a_Pat, b_Pat] [] (
409 compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
413 %************************************************************************
415 \subsubsection{Generating @Enum@ instance declarations}
417 %************************************************************************
419 @Enum@ can only be derived for enumeration types. For a type
421 data Foo ... = N1 | N2 | ... | Nn
424 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
425 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
428 instance ... Enum (Foo ...) where
429 succ x = toEnum (1 + fromEnum x)
430 pred x = toEnum (fromEnum x - 1)
432 toEnum i = tag2con_Foo i
434 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
438 = case con2tag_Foo a of
439 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
442 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
446 = case con2tag_Foo a of { a# ->
447 case con2tag_Foo b of { b# ->
448 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
452 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
455 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
458 = succ_enum `AndMonoBinds`
459 pred_enum `AndMonoBinds`
460 to_enum `AndMonoBinds`
461 enum_from `AndMonoBinds`
462 enum_from_then `AndMonoBinds`
465 tycon_loc = getSrcLoc tycon
466 occ_nm = getOccString tycon
469 = mk_easy_FunMonoBind tycon_loc succ_RDR [a_Pat] [] $
470 untag_Expr tycon [(a_RDR, ah_RDR)] $
471 HsIf (HsApp (HsApp (HsVar eq_RDR)
472 (HsVar (maxtag_RDR tycon)))
473 (mk_easy_App mkInt_RDR [ah_RDR]))
474 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
475 (HsApp (HsVar (tag2con_RDR tycon))
476 (HsApp (HsApp (HsVar plus_RDR)
477 (mk_easy_App mkInt_RDR [ah_RDR]))
482 = mk_easy_FunMonoBind tycon_loc pred_RDR [a_Pat] [] $
483 untag_Expr tycon [(a_RDR, ah_RDR)] $
484 HsIf (HsApp (HsApp (HsVar eq_RDR) (HsLit (HsInt 0)))
485 (mk_easy_App mkInt_RDR [ah_RDR]))
486 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
487 (HsApp (HsVar (tag2con_RDR tycon))
488 (HsApp (HsApp (HsVar plus_RDR)
489 (mk_easy_App mkInt_RDR [ah_RDR]))
490 (HsLit (HsInt (-1)))))
494 = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
497 (HsApp (HsApp (HsVar ge_RDR)
500 (HsApp (HsApp (HsVar le_RDR)
502 (HsVar (maxtag_RDR tycon))))
503 (mk_easy_App (tag2con_RDR tycon) [a_RDR])
504 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
508 = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
509 untag_Expr tycon [(a_RDR, ah_RDR)] $
510 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
511 HsPar (enum_from_to_Expr
512 (mk_easy_App mkInt_RDR [ah_RDR])
513 (HsVar (maxtag_RDR tycon)))
516 = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
517 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
518 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
519 HsPar (enum_from_then_to_Expr
520 (mk_easy_App mkInt_RDR [ah_RDR])
521 (mk_easy_App mkInt_RDR [bh_RDR])
522 (HsIf (HsApp (HsApp (HsVar gt_RDR)
523 (mk_easy_App mkInt_RDR [ah_RDR]))
524 (mk_easy_App mkInt_RDR [bh_RDR]))
526 (HsVar (maxtag_RDR tycon))
530 = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
531 untag_Expr tycon [(a_RDR, ah_RDR)] $
532 (mk_easy_App mkInt_RDR [ah_RDR])
535 %************************************************************************
537 \subsubsection{Generating @Bounded@ instance declarations}
539 %************************************************************************
542 gen_Bounded_binds tycon
543 = if isEnumerationTyCon tycon then
544 min_bound_enum `AndMonoBinds` max_bound_enum
546 ASSERT(length data_cons == 1)
547 min_bound_1con `AndMonoBinds` max_bound_1con
549 data_cons = tyConDataCons tycon
550 tycon_loc = getSrcLoc tycon
552 ----- enum-flavored: ---------------------------
553 min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
554 max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR)
556 data_con_1 = head data_cons
557 data_con_N = last data_cons
558 data_con_1_RDR = qual_orig_name data_con_1
559 data_con_N_RDR = qual_orig_name data_con_N
561 ----- single-constructor-flavored: -------------
562 arity = argFieldCount data_con_1
564 min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
565 mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
566 max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
567 mk_easy_App data_con_1_RDR (nOfThem arity maxBound_RDR)
570 %************************************************************************
572 \subsubsection{Generating @Ix@ instance declarations}
574 %************************************************************************
576 Deriving @Ix@ is only possible for enumeration types and
577 single-constructor types. We deal with them in turn.
579 For an enumeration type, e.g.,
581 data Foo ... = N1 | N2 | ... | Nn
583 things go not too differently from @Enum@:
585 instance ... Ix (Foo ...) where
587 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
591 = case (con2tag_Foo a) of { a# ->
592 case (con2tag_Foo b) of { b# ->
593 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
598 then case (con2tag_Foo d -# con2tag_Foo a) of
600 else error "Ix.Foo.index: out of range"
604 p_tag = con2tag_Foo c
606 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
610 = case (con2tag_Foo a) of { a_tag ->
611 case (con2tag_Foo b) of { b_tag ->
612 case (con2tag_Foo c) of { c_tag ->
613 if (c_tag >=# a_tag) then
619 (modulo suitable case-ification to handle the unboxed tags)
621 For a single-constructor type (NB: this includes all tuples), e.g.,
623 data Foo ... = MkFoo a b Int Double c c
625 we follow the scheme given in Figure~19 of the Haskell~1.2 report
629 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
632 = if isEnumerationTyCon tycon
636 tycon_str = getOccString tycon
637 tycon_loc = getSrcLoc tycon
639 --------------------------------------------------------------
640 enum_ixes = enum_range `AndMonoBinds`
641 enum_index `AndMonoBinds` enum_inRange
644 = mk_easy_FunMonoBind tycon_loc range_RDR
645 [TuplePatIn [a_Pat, b_Pat] True{-boxed-}] [] $
646 untag_Expr tycon [(a_RDR, ah_RDR)] $
647 untag_Expr tycon [(b_RDR, bh_RDR)] $
648 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
649 HsPar (enum_from_to_Expr
650 (mk_easy_App mkInt_RDR [ah_RDR])
651 (mk_easy_App mkInt_RDR [bh_RDR]))
654 = mk_easy_FunMonoBind tycon_loc index_RDR
655 [AsPatIn c_RDR (TuplePatIn [a_Pat, wildPat] True{-boxed-}),
657 HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
658 untag_Expr tycon [(a_RDR, ah_RDR)] (
659 untag_Expr tycon [(d_RDR, dh_RDR)] (
661 rhs = mk_easy_App mkInt_RDR [c_RDR]
664 (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
665 [mkSimpleMatch [VarPatIn c_RDR] rhs Nothing tycon_loc]
669 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
674 = mk_easy_FunMonoBind tycon_loc inRange_RDR
675 [TuplePatIn [a_Pat, b_Pat] True{-boxed-}, c_Pat] [] (
676 untag_Expr tycon [(a_RDR, ah_RDR)] (
677 untag_Expr tycon [(b_RDR, bh_RDR)] (
678 untag_Expr tycon [(c_RDR, ch_RDR)] (
679 HsIf (genOpApp (HsVar ch_RDR) geH_RDR (HsVar ah_RDR)) (
680 (genOpApp (HsVar ch_RDR) leH_RDR (HsVar bh_RDR))
685 --------------------------------------------------------------
687 = single_con_range `AndMonoBinds`
688 single_con_index `AndMonoBinds`
692 = case maybeTyConSingleCon tycon of -- just checking...
693 Nothing -> panic "get_Ix_binds"
694 Just dc -> if (any isUnLiftedType (dataConRawArgTys dc)) then
695 error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
699 con_arity = argFieldCount data_con
700 data_con_RDR = qual_orig_name data_con
702 as_needed = take con_arity as_RDRs
703 bs_needed = take con_arity bs_RDRs
704 cs_needed = take con_arity cs_RDRs
706 con_pat xs = ConPatIn data_con_RDR (map VarPatIn xs)
707 con_expr = mk_easy_App data_con_RDR cs_needed
709 --------------------------------------------------------------
711 = mk_easy_FunMonoBind tycon_loc range_RDR
712 [TuplePatIn [con_pat as_needed, con_pat bs_needed] True{-boxed-}] [] $
713 HsDo ListComp stmts tycon_loc
715 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
717 [ReturnStmt con_expr]
719 mk_qual a b c = BindStmt (VarPatIn c)
720 (HsApp (HsVar range_RDR)
721 (ExplicitTuple [HsVar a, HsVar b] True))
726 = mk_easy_FunMonoBind tycon_loc index_RDR
727 [TuplePatIn [con_pat as_needed, con_pat bs_needed] True,
728 con_pat cs_needed] [range_size] (
729 foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
731 mk_index multiply_by (l, u, i)
733 (HsApp (HsApp (HsVar index_RDR)
734 (ExplicitTuple [HsVar l, HsVar u] True)) (HsVar i))
737 (HsApp (HsVar rangeSize_RDR)
738 (ExplicitTuple [HsVar l, HsVar u] True))
739 ) times_RDR multiply_by
743 = mk_easy_FunMonoBind tycon_loc rangeSize_RDR
744 [TuplePatIn [a_Pat, b_Pat] True] [] (
746 (HsApp (HsApp (HsVar index_RDR)
747 (ExplicitTuple [a_Expr, b_Expr] True)) b_Expr)
748 ) plus_RDR (HsLit (HsInt 1)))
752 = mk_easy_FunMonoBind tycon_loc inRange_RDR
753 [TuplePatIn [con_pat as_needed, con_pat bs_needed] True,
756 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
758 in_range a b c = HsApp (HsApp (HsVar inRange_RDR)
759 (ExplicitTuple [HsVar a, HsVar b] True))
763 %************************************************************************
765 \subsubsection{Generating @Read@ instance declarations}
767 %************************************************************************
770 gen_Read_binds :: Fixities -> TyCon -> RdrNameMonoBinds
772 gen_Read_binds fixities tycon
773 = reads_prec `AndMonoBinds` read_list
775 tycon_loc = getSrcLoc tycon
776 -----------------------------------------------------------------------
777 read_list = mk_easy_FunMonoBind tycon_loc readList_RDR [] []
778 (HsApp (HsVar readList___RDR) (HsPar (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 0)))))
779 -----------------------------------------------------------------------
782 read_con_comprehensions
783 = map read_con (tyConDataCons tycon)
785 mk_easy_FunMonoBind tycon_loc readsPrec_RDR [_a_Pat, b_Pat] [] (
786 foldr1 append_Expr read_con_comprehensions
789 read_con data_con -- note: "b" is the string being "read"
791 readParen_Expr read_paren_arg $ HsPar $
792 HsLam (mk_easy_Match tycon_loc [c_Pat] [] $
793 HsDo ListComp stmts tycon_loc)
796 data_con_RDR = qual_orig_name data_con
797 data_con_str = occNameUserString (getOccName data_con)
798 con_arity = argFieldCount data_con
799 con_expr = mk_easy_App data_con_RDR as_needed
800 nullary_con = con_arity == 0
801 labels = dataConFieldLabels data_con
802 lab_fields = length labels
803 dc_nm = getName data_con
804 is_infix = isDataSymOcc (getOccName dc_nm)
806 as_needed = take con_arity as_RDRs
808 | is_infix = take (1 + con_arity) bs_RDRs
809 | lab_fields == 0 = take con_arity bs_RDRs
810 | otherwise = take (4*lab_fields + 1) bs_RDRs
811 -- (label, '=' and field)*n, (n-1)*',' + '{' + '}'
813 (as1:as2:_) = as_needed
814 (bs1:bs2:bs3:_) = bs_needed
819 (TuplePatIn [LitPatIn (mkHsString data_con_str), d_Pat] True)
820 (HsApp (HsVar lex_RDR) c_Expr)
824 (TuplePatIn [LitPatIn (mkHsString data_con_str), VarPatIn bs2] True)
825 (HsApp (HsVar lex_RDR) (HsVar bs1))
829 str_qual str res draw_from =
831 (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] True)
832 (HsApp (HsVar lex_RDR) draw_from)
835 str_qual_paren str res draw_from =
837 (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] True)
838 (HsApp (readParen_Expr true_Expr (HsVar lex_RDR)) draw_from)
841 read_label f = [rd_lab, str_qual "="]
842 -- There might be spaces between the label and '='
845 | is_op = str_qual_paren nm
846 | otherwise = str_qual nm
848 occ_nm = getOccName (fieldLabelName f)
849 is_op = isSymOcc occ_nm
850 nm = occNameUserString occ_nm
854 snd (mapAccumL mk_qual_infix
856 [ (mk_read_qual lp as1, bs1, bs2)
857 , (mk_read_qual rp as2, bs3, bs3)
859 | lab_fields == 0 = -- common case.
860 snd (mapAccumL mk_qual
862 (zipWithEqual "as_needed"
863 (\ con_field draw_from -> (mk_read_qual 10 con_field,
865 as_needed bs_needed))
868 mapAccumL mk_qual d_Expr
869 (zipEqual "bs_needed"
872 intersperse [str_qual ","] $
875 (\ as b -> as ++ [b])
877 (map read_label labels)
879 (map (mk_read_qual 10) as_needed))) ++ [str_qual "}"])
882 mk_qual_infix draw_from (f, str_left, str_left2) =
883 (HsVar str_left2, -- what to draw from down the line...
884 f str_left draw_from)
886 mk_qual draw_from (f, str_left) =
887 (HsVar str_left, -- what to draw from down the line...
888 f str_left draw_from)
890 mk_read_qual p con_field res draw_from =
892 (TuplePatIn [VarPatIn con_field, VarPatIn res] True)
893 (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt p))) draw_from)
896 result_expr = ExplicitTuple [con_expr, if null bs_needed
898 else HsVar (last bs_needed)] True
900 [lp,rp] = getLRPrecs fixities dc_nm
903 | is_infix = let (h:t) = field_quals in (h:con_qual:t)
904 | otherwise = con_qual:field_quals
906 stmts = quals ++ [ReturnStmt result_expr]
910 | otherwise = getFixity fixities dc_nm
912 read_paren_arg -- parens depend on precedence...
913 | nullary_con = false_Expr -- it's optional.
914 | otherwise = HsPar (genOpApp _a_Expr gt_RDR (HsLit (HsInt paren_prec_limit)))
917 %************************************************************************
919 \subsubsection{Generating @Show@ instance declarations}
921 %************************************************************************
924 gen_Show_binds :: Fixities -> TyCon -> RdrNameMonoBinds
926 gen_Show_binds fixs_assoc tycon
927 = shows_prec `AndMonoBinds` show_list
929 tycon_loc = getSrcLoc tycon
930 -----------------------------------------------------------------------
931 show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
932 (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 0)))))
933 -----------------------------------------------------------------------
934 shows_prec = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
937 | nullary_con = -- skip the showParen junk...
938 ASSERT(null bs_needed)
939 ([wildPat, con_pat], show_con)
942 showParen_Expr (HsPar (genOpApp a_Expr gt_RDR (HsLit (HsInt paren_prec_limit))))
943 (HsPar (nested_compose_Expr show_thingies)))
945 data_con_RDR = qual_orig_name data_con
946 con_arity = argFieldCount data_con
947 bs_needed = take con_arity bs_RDRs
948 con_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
949 nullary_con = con_arity == 0
950 labels = dataConFieldLabels data_con
951 lab_fields = length labels
953 dc_nm = getName data_con
954 dc_occ_nm = getOccName data_con
955 dc_occ_nm_str = occNameUserString dc_occ_nm
957 is_infix = isDataSymOcc dc_occ_nm
961 | is_infix = mk_showString_app (' ':dc_occ_nm_str)
962 | otherwise = mk_showString_app (dc_occ_nm_str ++ space_ocurly_maybe)
966 | lab_fields == 0 = " "
970 show_all con fs@(x:xs)
971 | is_infix = x:con:xs
975 | lab_fields > 0 = [mk_showString_app "}"]
978 con:fs ++ ccurly_maybe
980 show_thingies = show_all show_con real_show_thingies_with_labs
982 show_label l = mk_showString_app (the_name ++ "=")
984 occ_nm = getOccName (fieldLabelName l)
986 is_op = isSymOcc occ_nm
988 | is_op = '(':nm ++ ")"
991 nm = occNameUserString occ_nm
994 mk_showString_app str = HsApp (HsVar showString_RDR)
995 (HsLit (mkHsString str))
997 prec_cons = getLRPrecs fixs_assoc dc_nm
1001 [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt p))) (HsVar b)
1002 | (p,b) <- zip prec_cons bs_needed ]
1004 [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
1007 real_show_thingies_with_labs
1008 | lab_fields == 0 = intersperse (HsVar showSpace_RDR) real_show_thingies
1009 | otherwise = --Assumption: no of fields == no of labelled fields
1010 -- (and in same order)
1012 intersperse ([mk_showString_app ","]) $ -- Using SLIT()s containing ,s spells trouble.
1013 zipWithEqual "gen_Show_binds"
1015 (map show_label labels)
1018 (con_left_assoc, con_right_assoc) = isLRAssoc fixs_assoc dc_nm
1022 | otherwise = getFixity fixs_assoc dc_nm
1027 getLRPrecs :: Fixities -> Name -> [Integer]
1028 getLRPrecs fixs_assoc nm = [lp, rp]
1030 ( con_left_assoc, con_right_assoc) = isLRAssoc fixs_assoc nm
1031 paren_prec_limit = 9
1034 | con_left_assoc = paren_prec_limit
1035 | otherwise = paren_prec_limit + 1
1038 | con_right_assoc = paren_prec_limit
1039 | otherwise = paren_prec_limit + 1
1042 getFixity :: Fixities -> Name -> Integer
1043 getFixity fixs_assoc nm =
1044 case assocMaybe fixs_assoc nm of
1046 Just (Fixity x _) -> fromInt x + 1
1048 isLRAssoc :: Fixities -> Name -> (Bool, Bool)
1049 isLRAssoc fixs_assoc nm =
1050 case assocMaybe fixs_assoc nm of
1051 Just (Fixity _ InfixL) -> (True, False)
1052 Just (Fixity _ InfixR) -> (False, True)
1053 Just (Fixity _ _) -> (False, False)
1059 %************************************************************************
1061 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1063 %************************************************************************
1068 con2tag_Foo :: Foo ... -> Int#
1069 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1070 maxtag_Foo :: Int -- ditto (NB: not unboxed)
1073 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1078 = GenCon2Tag | GenTag2Con | GenMaxTag
1080 gen_tag_n_con_monobind
1081 :: (RdrName, -- (proto)Name for the thing in question
1082 TyCon, -- tycon in question
1086 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1087 | lots_of_constructors
1088 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1089 [([VarPatIn a_RDR], HsApp getTag_Expr a_Expr)]
1092 = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
1095 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1097 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
1099 = ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
1101 pat = ConPatIn var_RDR (nOfThem (argFieldCount var) WildPatIn)
1102 var_RDR = qual_orig_name var
1104 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1105 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1106 [([ConPatIn mkInt_RDR [VarPatIn a_RDR]],
1107 ExprWithTySig (HsApp tagToEnum_Expr a_Expr)
1108 (MonoTyVar (qual_orig_name tycon)))]
1110 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1111 = mk_easy_FunMonoBind (getSrcLoc tycon)
1112 rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
1114 max_tag = case (tyConDataCons tycon) of
1115 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1119 %************************************************************************
1121 \subsection{Utility bits for generating bindings}
1123 %************************************************************************
1125 @mk_easy_FunMonoBind fun pats binds expr@ generates:
1127 fun pat1 pat2 ... patN = expr where binds
1130 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
1131 multi-clause definitions; it generates:
1133 fun p1a p1b ... p1N = e1
1134 fun p2a p2b ... p2N = e2
1136 fun pMa pMb ... pMN = eM
1140 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
1141 -> [RdrNameMonoBinds] -> RdrNameHsExpr
1144 mk_easy_FunMonoBind loc fun pats binds expr
1145 = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
1147 mk_easy_Match loc pats binds expr
1148 = mk_match loc pats expr (mkbind binds)
1150 mkbind [] = EmptyBinds
1151 mkbind bs = MonoBind (foldr1 AndMonoBinds bs) [] Recursive
1152 -- The renamer expects everything in its input to be a
1153 -- "recursive" MonoBinds, and it is its job to sort things out
1156 mk_FunMonoBind :: SrcLoc -> RdrName
1157 -> [([RdrNamePat], RdrNameHsExpr)]
1160 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
1161 mk_FunMonoBind loc fun pats_and_exprs
1162 = FunMonoBind fun False{-not infix-}
1163 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
1166 mk_match loc pats expr binds
1167 = Match [] (map paren pats) Nothing
1168 (GRHSs (unguardedRHS expr loc) binds Nothing)
1170 paren p@(VarPatIn _) = p
1171 paren other_p = ParPatIn other_p
1175 mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
1178 ToDo: Better SrcLocs.
1182 RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1183 -> RdrNameHsExpr -> RdrNameHsExpr
1187 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1188 -> RdrNameHsExpr -> RdrNameHsExpr
1190 careful_compare_Case :: -- checks for primitive types...
1192 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1193 -> RdrNameHsExpr -> RdrNameHsExpr
1196 compare_Case = compare_gen_Case compare_RDR
1197 cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b
1198 -- Was: compare_gen_Case cmp_eq_RDR
1200 compare_gen_Case fun lt eq gt a b
1201 = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
1202 [mkSimpleMatch [ConPatIn ltTag_RDR []] lt Nothing mkGeneratedSrcLoc,
1203 mkSimpleMatch [ConPatIn eqTag_RDR []] eq Nothing mkGeneratedSrcLoc,
1204 mkSimpleMatch [ConPatIn gtTag_RDR []] gt Nothing mkGeneratedSrcLoc]
1207 careful_compare_Case ty lt eq gt a b
1208 = if not (isUnboxedType ty) then
1209 compare_gen_Case compare_RDR lt eq gt a b
1211 else -- we have to do something special for primitive things...
1212 HsIf (genOpApp a relevant_eq_op b)
1214 (HsIf (genOpApp a relevant_lt_op b) lt gt mkGeneratedSrcLoc)
1217 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1218 relevant_lt_op = assoc_ty_id lt_op_tbl ty
1220 assoc_ty_id tyids ty
1221 = if null res then panic "assoc_ty"
1224 res = [id | (ty',id) <- tyids, ty == ty']
1227 [(charPrimTy, eqH_Char_RDR)
1228 ,(intPrimTy, eqH_Int_RDR)
1229 ,(wordPrimTy, eqH_Word_RDR)
1230 ,(addrPrimTy, eqH_Addr_RDR)
1231 ,(floatPrimTy, eqH_Float_RDR)
1232 ,(doublePrimTy, eqH_Double_RDR)
1236 [(charPrimTy, ltH_Char_RDR)
1237 ,(intPrimTy, ltH_Int_RDR)
1238 ,(wordPrimTy, ltH_Word_RDR)
1239 ,(addrPrimTy, ltH_Addr_RDR)
1240 ,(floatPrimTy, ltH_Float_RDR)
1241 ,(doublePrimTy, ltH_Double_RDR)
1244 -----------------------------------------------------------------------
1246 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1248 and_Expr a b = genOpApp a and_RDR b
1249 append_Expr a b = genOpApp a append_RDR b
1251 -----------------------------------------------------------------------
1253 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1255 = if not (isUnboxedType ty) then
1257 else -- we have to do something special for primitive things...
1258 genOpApp a relevant_eq_op b
1260 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1264 argFieldCount :: DataCon -> Int -- Works on data and newtype constructors
1265 argFieldCount con = length (dataConRawArgTys con)
1269 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
1270 untag_Expr tycon [] expr = expr
1271 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1272 = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1273 [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) Nothing mkGeneratedSrcLoc]
1276 cmp_tags_Expr :: RdrName -- Comparison op
1277 -> RdrName -> RdrName -- Things to compare
1278 -> RdrNameHsExpr -- What to return if true
1279 -> RdrNameHsExpr -- What to return if false
1282 cmp_tags_Expr op a b true_case false_case
1283 = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case mkGeneratedSrcLoc
1286 :: RdrNameHsExpr -> RdrNameHsExpr
1288 enum_from_then_to_Expr
1289 :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1292 enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1293 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1295 showParen_Expr, readParen_Expr
1296 :: RdrNameHsExpr -> RdrNameHsExpr
1299 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1300 readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_RDR) e1) e2
1302 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1304 nested_compose_Expr [e] = parenify e
1305 nested_compose_Expr (e:es)
1306 = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1308 -- impossible_Expr is used in case RHSs that should never happen.
1309 -- We generate these to keep the desugarer from complaining that they *might* happen!
1310 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ "Urk! in TcGenDeriv")))
1312 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1313 -- method. It is currently only used by Enum.{succ,pred}
1314 illegal_Expr meth tp msg =
1315 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ (meth ++ '{':tp ++ "}: " ++ msg))))
1317 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1318 -- to include the value of a_RDR in the error string.
1319 illegal_toEnum_tag tp maxtag =
1320 HsApp (HsVar error_RDR)
1321 (HsApp (HsApp (HsVar append_RDR)
1322 (HsLit (HsString (_PK_ ("toEnum{" ++ tp ++ "}: tag (")))))
1323 (HsApp (HsApp (HsApp
1324 (HsVar showsPrec_RDR)
1329 (HsLit (HsString (_PK_ ") is outside of enumeration's range (0,"))))
1330 (HsApp (HsApp (HsApp
1331 (HsVar showsPrec_RDR)
1334 (HsLit (HsString (_PK_ ")")))))))
1336 parenify e@(HsVar _) = e
1337 parenify e = HsPar e
1339 -- genOpApp wraps brackets round the operator application, so that the
1340 -- renamer won't subsequently try to re-associate it.
1341 -- For some reason the renamer doesn't reassociate it right, and I can't
1342 -- be bothered to find out why just now.
1344 genOpApp e1 op e2 = mkOpApp e1 op e2
1348 qual_orig_name n = nameRdrName (getName n)
1349 varUnqual n = mkSrcUnqual varName n
1351 _a_RDR = varUnqual SLIT("_a")
1352 a_RDR = varUnqual SLIT("a")
1353 b_RDR = varUnqual SLIT("b")
1354 c_RDR = varUnqual SLIT("c")
1355 d_RDR = varUnqual SLIT("d")
1356 ah_RDR = varUnqual SLIT("a#")
1357 bh_RDR = varUnqual SLIT("b#")
1358 ch_RDR = varUnqual SLIT("c#")
1359 dh_RDR = varUnqual SLIT("d#")
1360 cmp_eq_RDR = varUnqual SLIT("cmp_eq")
1361 rangeSize_RDR = varUnqual SLIT("rangeSize")
1363 as_RDRs = [ varUnqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
1364 bs_RDRs = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
1365 cs_RDRs = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
1367 mkHsString s = HsString (_PK_ s)
1369 _a_Expr = HsVar _a_RDR
1370 a_Expr = HsVar a_RDR
1371 b_Expr = HsVar b_RDR
1372 c_Expr = HsVar c_RDR
1373 d_Expr = HsVar d_RDR
1374 ltTag_Expr = HsVar ltTag_RDR
1375 eqTag_Expr = HsVar eqTag_RDR
1376 gtTag_Expr = HsVar gtTag_RDR
1377 false_Expr = HsVar false_RDR
1378 true_Expr = HsVar true_RDR
1380 getTag_Expr = HsVar getTag_RDR
1381 tagToEnum_Expr = HsVar tagToEnumH_RDR
1382 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1385 _a_Pat = VarPatIn _a_RDR
1386 a_Pat = VarPatIn a_RDR
1387 b_Pat = VarPatIn b_RDR
1388 c_Pat = VarPatIn c_RDR
1389 d_Pat = VarPatIn d_RDR
1391 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1393 con2tag_RDR tycon = varUnqual (_PK_ ("con2tag_" ++ occNameString (getOccName tycon) ++ "#"))
1394 tag2con_RDR tycon = varUnqual (_PK_ ("tag2con_" ++ occNameString (getOccName tycon) ++ "#"))
1395 maxtag_RDR tycon = varUnqual (_PK_ ("maxtag_" ++ occNameString (getOccName tycon) ++ "#"))