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, mkMonoBind, andMonoBindList
34 import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
35 import RdrName ( RdrName, mkUnqual )
36 import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..)
40 import FieldLabel ( fieldLabelName )
41 import DataCon ( isNullaryDataCon, dataConTag,
42 dataConOrigArgTys, dataConSourceArity, fIRST_TAG,
45 import Name ( getOccString, getOccName, getSrcLoc, occNameString,
46 occNameUserString, nameRdrName, varName,
48 isDataSymOcc, isSymOcc
51 import PrelInfo -- Lots of RdrNames
52 import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
53 import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
54 maybeTyConSingleCon, tyConFamilySize
56 import Type ( isUnLiftedType, isUnboxedType, Type )
57 import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
58 floatPrimTy, doublePrimTy
60 import Util ( mapAccumL, zipEqual, zipWithEqual,
61 zipWith3Equal, nOfThem )
62 import Panic ( panic, assertPanic )
63 import Maybes ( maybeToBool )
65 import List ( partition, intersperse )
67 #if __GLASGOW_HASKELL__ >= 404
68 import GlaExts ( fromInt )
72 %************************************************************************
74 \subsection{Generating code, by derivable class}
76 %************************************************************************
78 %************************************************************************
80 \subsubsection{Generating @Eq@ instance declarations}
82 %************************************************************************
84 Here are the heuristics for the code we generate for @Eq@:
87 Let's assume we have a data type with some (possibly zero) nullary
88 data constructors and some ordinary, non-nullary ones (the rest,
89 also possibly zero of them). Here's an example, with both \tr{N}ullary
90 and \tr{O}rdinary data cons.
92 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
96 For the ordinary constructors (if any), we emit clauses to do The
100 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
101 (==) (O2 a1) (O2 a2) = a1 == a2
102 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
105 Note: if we're comparing unboxed things, e.g., if \tr{a1} and
106 \tr{a2} are \tr{Float#}s, then we have to generate
108 case (a1 `eqFloat#` a2) of
111 for that particular test.
114 If there are any nullary constructors, we emit a catch-all clause of
118 (==) a b = case (con2tag_Foo a) of { a# ->
119 case (con2tag_Foo b) of { b# ->
120 case (a# ==# b#) of {
125 If there aren't any nullary constructors, we emit a simpler
132 For the @(/=)@ method, we normally just use the default method.
134 If the type is an enumeration type, we could/may/should? generate
135 special code that calls @con2tag_Foo@, much like for @(==)@ shown
139 We thought about doing this: If we're also deriving @Ord@ for this
142 instance ... Eq (Foo ...) where
143 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
144 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
146 However, that requires that \tr{Ord <whatever>} was put in the context
147 for the instance decl, which it probably wasn't, so the decls
148 produced don't get through the typechecker.
152 deriveEq :: RdrName -- Class
153 -> RdrName -- Type constructor
154 -> [ (RdrName, [RdrType]) ] -- Constructors
155 -> (RdrContext, -- Context for the inst decl
156 [RdrBind], -- Binds in the inst decl
157 [RdrBind]) -- Extra value bindings outside
159 deriveEq clas tycon constrs
160 = (context, [eq_bind, ne_bind], [])
162 context = [(clas, [ty]) | (_, tys) <- constrs, ty <- tys]
165 (nullary_cons, non_nullary_cons) = partition is_nullary constrs
166 is_nullary (_, args) = null args
169 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
173 tycon_loc = getSrcLoc tycon
174 (nullary_cons, nonnullary_cons)
175 | isNewTyCon tycon = ([], tyConDataCons tycon)
176 | otherwise = partition isNullaryDataCon (tyConDataCons tycon)
179 = if (null nullary_cons) then
180 case maybeTyConSingleCon tycon of
182 Nothing -> -- if cons don't match, then False
183 [([wildPat, wildPat], false_Expr)]
184 else -- calc. and compare the tags
186 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
187 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR true_Expr false_Expr))]
189 mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
191 mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
192 HsApp (HsVar not_RDR) (HsPar (mk_easy_App eq_RDR [a_RDR, b_RDR])))
194 ------------------------------------------------------------------
197 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
198 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
200 data_con_RDR = qual_orig_name data_con
201 con_arity = length tys_needed
202 as_needed = take con_arity as_RDRs
203 bs_needed = take con_arity bs_RDRs
204 tys_needed = dataConOrigArgTys data_con
206 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
208 nested_eq_expr [] [] [] = true_Expr
209 nested_eq_expr tys as bs
210 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
212 nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
215 %************************************************************************
217 \subsubsection{Generating @Ord@ instance declarations}
219 %************************************************************************
221 For a derived @Ord@, we concentrate our attentions on @compare@
223 compare :: a -> a -> Ordering
224 data Ordering = LT | EQ | GT deriving ()
227 We will use the same example data type as above:
229 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
234 We do all the other @Ord@ methods with calls to @compare@:
236 instance ... (Ord <wurble> <wurble>) where
237 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
238 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
239 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
240 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
242 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
243 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
245 -- compare to come...
249 @compare@ always has two parts. First, we use the compared
250 data-constructors' tags to deal with the case of different
253 compare a b = case (con2tag_Foo a) of { a# ->
254 case (con2tag_Foo b) of { b# ->
255 case (a# ==# b#) of {
257 False -> case (a# <# b#) of
262 cmp_eq = ... to come ...
266 We are only left with the ``help'' function @cmp_eq@, to deal with
267 comparing data constructors with the same tag.
269 For the ordinary constructors (if any), we emit the sorta-obvious
270 compare-style stuff; for our example:
272 cmp_eq (O1 a1 b1) (O1 a2 b2)
273 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
275 cmp_eq (O2 a1) (O2 a2)
278 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
279 = case (compare a1 a2) of {
282 EQ -> case compare b1 b2 of {
290 Again, we must be careful about unboxed comparisons. For example,
291 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
295 cmp_eq lt eq gt (O2 a1) (O2 a2)
297 -- or maybe the unfolded equivalent
301 For the remaining nullary constructors, we already know that the
308 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
312 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
315 = compare -- `AndMonoBinds` compare
316 -- The default declaration in PrelBase handles this
318 tycon_loc = getSrcLoc tycon
319 --------------------------------------------------------------------
320 compare = mk_easy_FunMonoBind tycon_loc compare_RDR
323 (if maybeToBool (maybeTyConSingleCon tycon) then
325 -- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
326 -- Wierd. Was: case (cmp a b) of { LT -> LT; EQ -> EQ; GT -> GT }
328 cmp_eq_Expr a_Expr b_Expr
330 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
331 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR
332 -- True case; they are equal
333 -- If an enumeration type we are done; else
334 -- recursively compare their components
335 (if isEnumerationTyCon tycon then
338 -- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
340 cmp_eq_Expr a_Expr b_Expr
342 -- False case; they aren't equal
343 -- So we need to do a less-than comparison on the tags
344 (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
346 tycon_data_cons = tyConDataCons tycon
347 (nullary_cons, nonnullary_cons)
348 | isNewTyCon tycon = ([], tyConDataCons tycon)
349 | otherwise = partition isNullaryDataCon tycon_data_cons
352 mk_FunMonoBind tycon_loc
354 (if null nonnullary_cons && (length nullary_cons == 1) then
355 -- catch this specially to avoid warnings
356 -- about overlapping patterns from the desugarer.
358 data_con = head nullary_cons
359 data_con_RDR = qual_orig_name data_con
360 pat = ConPatIn data_con_RDR []
362 [([pat,pat], eqTag_Expr)]
364 map pats_etc nonnullary_cons ++
365 -- leave out wildcards to silence desugarer.
366 (if length tycon_data_cons == 1 then
369 [([WildPatIn, WildPatIn], default_rhs)]))
372 = ([con1_pat, con2_pat],
373 nested_compare_expr tys_needed as_needed bs_needed)
375 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
376 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
378 data_con_RDR = qual_orig_name data_con
379 con_arity = length tys_needed
380 as_needed = take con_arity as_RDRs
381 bs_needed = take con_arity bs_RDRs
382 tys_needed = dataConOrigArgTys data_con
384 nested_compare_expr [ty] [a] [b]
385 = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
387 nested_compare_expr (ty:tys) (a:as) (b:bs)
388 = let eq_expr = nested_compare_expr tys as bs
389 in careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
391 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
392 -- inexhaustive patterns
393 | otherwise = eqTag_Expr -- Some nullary constructors;
394 -- Tags are equal, no args => return EQ
395 --------------------------------------------------------------------
397 {- Not necessary: the default decls in PrelBase handle these
399 defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
401 lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] (
402 compare_Case true_Expr false_Expr false_Expr a_Expr b_Expr)
403 le = mk_easy_FunMonoBind mkGeneratedSrcLoc le_RDR [a_Pat, b_Pat] [] (
404 compare_Case true_Expr true_Expr false_Expr a_Expr b_Expr)
405 ge = mk_easy_FunMonoBind mkGeneratedSrcLoc ge_RDR [a_Pat, b_Pat] [] (
406 compare_Case false_Expr true_Expr true_Expr a_Expr b_Expr)
407 gt = mk_easy_FunMonoBind mkGeneratedSrcLoc gt_RDR [a_Pat, b_Pat] [] (
408 compare_Case false_Expr false_Expr true_Expr a_Expr b_Expr)
410 max_ = mk_easy_FunMonoBind mkGeneratedSrcLoc max_RDR [a_Pat, b_Pat] [] (
411 compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
412 min_ = mk_easy_FunMonoBind mkGeneratedSrcLoc min_RDR [a_Pat, b_Pat] [] (
413 compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
417 %************************************************************************
419 \subsubsection{Generating @Enum@ instance declarations}
421 %************************************************************************
423 @Enum@ can only be derived for enumeration types. For a type
425 data Foo ... = N1 | N2 | ... | Nn
428 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
429 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
432 instance ... Enum (Foo ...) where
433 succ x = toEnum (1 + fromEnum x)
434 pred x = toEnum (fromEnum x - 1)
436 toEnum i = tag2con_Foo i
438 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
442 = case con2tag_Foo a of
443 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
446 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
450 = case con2tag_Foo a of { a# ->
451 case con2tag_Foo b of { b# ->
452 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
456 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
459 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
462 = succ_enum `AndMonoBinds`
463 pred_enum `AndMonoBinds`
464 to_enum `AndMonoBinds`
465 enum_from `AndMonoBinds`
466 enum_from_then `AndMonoBinds`
469 tycon_loc = getSrcLoc tycon
470 occ_nm = getOccString tycon
473 = mk_easy_FunMonoBind tycon_loc succ_RDR [a_Pat] [] $
474 untag_Expr tycon [(a_RDR, ah_RDR)] $
475 HsIf (HsApp (HsApp (HsVar eq_RDR)
476 (HsVar (maxtag_RDR tycon)))
477 (mk_easy_App mkInt_RDR [ah_RDR]))
478 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
479 (HsApp (HsVar (tag2con_RDR tycon))
480 (HsApp (HsApp (HsVar plus_RDR)
481 (mk_easy_App mkInt_RDR [ah_RDR]))
486 = mk_easy_FunMonoBind tycon_loc pred_RDR [a_Pat] [] $
487 untag_Expr tycon [(a_RDR, ah_RDR)] $
488 HsIf (HsApp (HsApp (HsVar eq_RDR) (HsLit (HsInt 0)))
489 (mk_easy_App mkInt_RDR [ah_RDR]))
490 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
491 (HsApp (HsVar (tag2con_RDR tycon))
492 (HsApp (HsApp (HsVar plus_RDR)
493 (mk_easy_App mkInt_RDR [ah_RDR]))
494 (HsLit (HsInt (-1)))))
498 = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
501 (HsApp (HsApp (HsVar ge_RDR)
504 (HsApp (HsApp (HsVar le_RDR)
506 (HsVar (maxtag_RDR tycon))))
507 (mk_easy_App (tag2con_RDR tycon) [a_RDR])
508 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
512 = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
513 untag_Expr tycon [(a_RDR, ah_RDR)] $
514 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
515 HsPar (enum_from_to_Expr
516 (mk_easy_App mkInt_RDR [ah_RDR])
517 (HsVar (maxtag_RDR tycon)))
520 = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
521 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
522 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
523 HsPar (enum_from_then_to_Expr
524 (mk_easy_App mkInt_RDR [ah_RDR])
525 (mk_easy_App mkInt_RDR [bh_RDR])
526 (HsIf (HsApp (HsApp (HsVar gt_RDR)
527 (mk_easy_App mkInt_RDR [ah_RDR]))
528 (mk_easy_App mkInt_RDR [bh_RDR]))
530 (HsVar (maxtag_RDR tycon))
534 = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
535 untag_Expr tycon [(a_RDR, ah_RDR)] $
536 (mk_easy_App mkInt_RDR [ah_RDR])
539 %************************************************************************
541 \subsubsection{Generating @Bounded@ instance declarations}
543 %************************************************************************
546 gen_Bounded_binds tycon
547 = if isEnumerationTyCon tycon then
548 min_bound_enum `AndMonoBinds` max_bound_enum
550 ASSERT(length data_cons == 1)
551 min_bound_1con `AndMonoBinds` max_bound_1con
553 data_cons = tyConDataCons tycon
554 tycon_loc = getSrcLoc tycon
556 ----- enum-flavored: ---------------------------
557 min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
558 max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR)
560 data_con_1 = head data_cons
561 data_con_N = last data_cons
562 data_con_1_RDR = qual_orig_name data_con_1
563 data_con_N_RDR = qual_orig_name data_con_N
565 ----- single-constructor-flavored: -------------
566 arity = dataConSourceArity data_con_1
568 min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
569 mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
570 max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
571 mk_easy_App data_con_1_RDR (nOfThem arity maxBound_RDR)
574 %************************************************************************
576 \subsubsection{Generating @Ix@ instance declarations}
578 %************************************************************************
580 Deriving @Ix@ is only possible for enumeration types and
581 single-constructor types. We deal with them in turn.
583 For an enumeration type, e.g.,
585 data Foo ... = N1 | N2 | ... | Nn
587 things go not too differently from @Enum@:
589 instance ... Ix (Foo ...) where
591 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
595 = case (con2tag_Foo a) of { a# ->
596 case (con2tag_Foo b) of { b# ->
597 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
602 then case (con2tag_Foo d -# con2tag_Foo a) of
604 else error "Ix.Foo.index: out of range"
608 p_tag = con2tag_Foo c
610 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
614 = case (con2tag_Foo a) of { a_tag ->
615 case (con2tag_Foo b) of { b_tag ->
616 case (con2tag_Foo c) of { c_tag ->
617 if (c_tag >=# a_tag) then
623 (modulo suitable case-ification to handle the unboxed tags)
625 For a single-constructor type (NB: this includes all tuples), e.g.,
627 data Foo ... = MkFoo a b Int Double c c
629 we follow the scheme given in Figure~19 of the Haskell~1.2 report
633 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
636 = if isEnumerationTyCon tycon
640 tycon_str = getOccString tycon
641 tycon_loc = getSrcLoc tycon
643 --------------------------------------------------------------
644 enum_ixes = enum_range `AndMonoBinds`
645 enum_index `AndMonoBinds` enum_inRange
648 = mk_easy_FunMonoBind tycon_loc range_RDR
649 [TuplePatIn [a_Pat, b_Pat] Boxed] [] $
650 untag_Expr tycon [(a_RDR, ah_RDR)] $
651 untag_Expr tycon [(b_RDR, bh_RDR)] $
652 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
653 HsPar (enum_from_to_Expr
654 (mk_easy_App mkInt_RDR [ah_RDR])
655 (mk_easy_App mkInt_RDR [bh_RDR]))
658 = mk_easy_FunMonoBind tycon_loc index_RDR
659 [AsPatIn c_RDR (TuplePatIn [a_Pat, wildPat] Boxed),
661 HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
662 untag_Expr tycon [(a_RDR, ah_RDR)] (
663 untag_Expr tycon [(d_RDR, dh_RDR)] (
665 rhs = mk_easy_App mkInt_RDR [c_RDR]
668 (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
669 [mkSimpleMatch [VarPatIn c_RDR] rhs Nothing tycon_loc]
673 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
678 = mk_easy_FunMonoBind tycon_loc inRange_RDR
679 [TuplePatIn [a_Pat, b_Pat] Boxed, c_Pat] [] (
680 untag_Expr tycon [(a_RDR, ah_RDR)] (
681 untag_Expr tycon [(b_RDR, bh_RDR)] (
682 untag_Expr tycon [(c_RDR, ch_RDR)] (
683 HsIf (genOpApp (HsVar ch_RDR) geH_RDR (HsVar ah_RDR)) (
684 (genOpApp (HsVar ch_RDR) leH_RDR (HsVar bh_RDR))
689 --------------------------------------------------------------
691 = single_con_range `AndMonoBinds`
692 single_con_index `AndMonoBinds`
696 = case maybeTyConSingleCon tycon of -- just checking...
697 Nothing -> panic "get_Ix_binds"
698 Just dc -> if (any isUnLiftedType (dataConOrigArgTys dc)) then
699 error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
703 con_arity = dataConSourceArity data_con
704 data_con_RDR = qual_orig_name data_con
706 as_needed = take con_arity as_RDRs
707 bs_needed = take con_arity bs_RDRs
708 cs_needed = take con_arity cs_RDRs
710 con_pat xs = ConPatIn data_con_RDR (map VarPatIn xs)
711 con_expr = mk_easy_App data_con_RDR cs_needed
713 --------------------------------------------------------------
715 = mk_easy_FunMonoBind tycon_loc range_RDR
716 [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed] [] $
717 HsDo ListComp stmts tycon_loc
719 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
721 [ReturnStmt con_expr]
723 mk_qual a b c = BindStmt (VarPatIn c)
724 (HsApp (HsVar range_RDR)
725 (ExplicitTuple [HsVar a, HsVar b] Boxed))
730 = mk_easy_FunMonoBind tycon_loc index_RDR
731 [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed,
732 con_pat cs_needed] [range_size] (
733 foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
735 mk_index multiply_by (l, u, i)
737 (HsApp (HsApp (HsVar index_RDR)
738 (ExplicitTuple [HsVar l, HsVar u] Boxed)) (HsVar i))
741 (HsApp (HsVar rangeSize_RDR)
742 (ExplicitTuple [HsVar l, HsVar u] Boxed))
743 ) times_RDR multiply_by
747 = mk_easy_FunMonoBind tycon_loc rangeSize_RDR
748 [TuplePatIn [a_Pat, b_Pat] Boxed] [] (
750 (HsApp (HsApp (HsVar index_RDR)
751 (ExplicitTuple [a_Expr, b_Expr] Boxed)) b_Expr)
752 ) plus_RDR (HsLit (HsInt 1)))
756 = mk_easy_FunMonoBind tycon_loc inRange_RDR
757 [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed,
760 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
762 in_range a b c = HsApp (HsApp (HsVar inRange_RDR)
763 (ExplicitTuple [HsVar a, HsVar b] Boxed))
767 %************************************************************************
769 \subsubsection{Generating @Read@ instance declarations}
771 %************************************************************************
774 gen_Read_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
776 gen_Read_binds gst tycon
777 = reads_prec `AndMonoBinds` read_list
779 tycon_loc = getSrcLoc tycon
780 -----------------------------------------------------------------------
781 read_list = mk_easy_FunMonoBind tycon_loc readList_RDR [] []
782 (HsApp (HsVar readList___RDR) (HsPar (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 0)))))
783 -----------------------------------------------------------------------
786 read_con_comprehensions
787 = map read_con (tyConDataCons tycon)
789 mk_easy_FunMonoBind tycon_loc readsPrec_RDR [zz_a_Pat, b_Pat] [] (
790 foldr1 append_Expr read_con_comprehensions
793 read_con data_con -- note: "b" is the string being "read"
795 readParen_Expr read_paren_arg $ HsPar $
796 HsLam (mk_easy_Match tycon_loc [c_Pat] [] $
797 HsDo ListComp stmts tycon_loc)
800 data_con_RDR = qual_orig_name data_con
801 data_con_str = occNameUserString (getOccName data_con)
802 con_arity = dataConSourceArity data_con
803 con_expr = mk_easy_App data_con_RDR as_needed
804 nullary_con = con_arity == 0
805 labels = dataConFieldLabels data_con
806 lab_fields = length labels
807 dc_nm = getName data_con
808 is_infix = isDataSymOcc (getOccName dc_nm)
810 as_needed = take con_arity as_RDRs
812 | is_infix = take (1 + con_arity) bs_RDRs
813 | lab_fields == 0 = take con_arity bs_RDRs
814 | otherwise = take (4*lab_fields + 1) bs_RDRs
815 -- (label, '=' and field)*n, (n-1)*',' + '{' + '}'
817 (as1:as2:_) = as_needed
818 (bs1:bs2:bs3:_) = bs_needed
823 (TuplePatIn [LitPatIn (mkHsString data_con_str), d_Pat] Boxed)
824 (HsApp (HsVar lex_RDR) c_Expr)
828 (TuplePatIn [LitPatIn (mkHsString data_con_str), VarPatIn bs2] Boxed)
829 (HsApp (HsVar lex_RDR) (HsVar bs1))
833 str_qual str res draw_from =
835 (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed)
836 (HsApp (HsVar lex_RDR) draw_from)
839 str_qual_paren str res draw_from =
841 (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed)
842 (HsApp (readParen_Expr true_Expr (HsVar lex_RDR)) draw_from)
845 read_label f = [rd_lab, str_qual "="]
846 -- There might be spaces between the label and '='
849 | is_op = str_qual_paren nm
850 | otherwise = str_qual nm
852 occ_nm = getOccName (fieldLabelName f)
853 is_op = isSymOcc occ_nm
854 nm = occNameUserString occ_nm
858 snd (mapAccumL mk_qual_infix
860 [ (mk_read_qual lp as1, bs1, bs2)
861 , (mk_read_qual rp as2, bs3, bs3)
863 | lab_fields == 0 = -- common case.
864 snd (mapAccumL mk_qual
866 (zipWithEqual "as_needed"
867 (\ con_field draw_from -> (mk_read_qual 10 con_field,
869 as_needed bs_needed))
872 mapAccumL mk_qual d_Expr
873 (zipEqual "bs_needed"
876 intersperse [str_qual ","] $
879 (\ as b -> as ++ [b])
881 (map read_label labels)
883 (map (mk_read_qual 10) as_needed))) ++ [str_qual "}"])
886 mk_qual_infix draw_from (f, str_left, str_left2) =
887 (HsVar str_left2, -- what to draw from down the line...
888 f str_left draw_from)
890 mk_qual draw_from (f, str_left) =
891 (HsVar str_left, -- what to draw from down the line...
892 f str_left draw_from)
894 mk_read_qual p con_field res draw_from =
896 (TuplePatIn [VarPatIn con_field, VarPatIn res] Boxed)
897 (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt p))) draw_from)
900 result_expr = ExplicitTuple [con_expr, if null bs_needed
902 else HsVar (last bs_needed)] Boxed
904 [lp,rp] = getLRPrecs is_infix gst dc_nm
907 | is_infix = let (h:t) = field_quals in (h:con_qual:t)
908 | otherwise = con_qual:field_quals
910 stmts = quals ++ [ReturnStmt result_expr]
913 c.f. Figure 18 in Haskell 1.1 report.
916 | not is_infix = fromInt maxPrecedence
917 | otherwise = getFixity gst dc_nm
919 read_paren_arg -- parens depend on precedence...
920 | nullary_con = false_Expr -- it's optional.
921 | otherwise = HsPar (genOpApp zz_a_Expr gt_RDR (HsLit (HsInt paren_prec_limit)))
924 %************************************************************************
926 \subsubsection{Generating @Show@ instance declarations}
928 %************************************************************************
931 gen_Show_binds :: GlobalSymbolTable -> TyCon -> RdrNameMonoBinds
933 gen_Show_binds gst tycon
934 = shows_prec `AndMonoBinds` show_list
936 tycon_loc = getSrcLoc tycon
937 -----------------------------------------------------------------------
938 show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
939 (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 0)))))
940 -----------------------------------------------------------------------
941 shows_prec = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
944 | nullary_con = -- skip the showParen junk...
945 ASSERT(null bs_needed)
946 ([wildPat, con_pat], show_con)
949 showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt paren_prec_limit))))
950 (HsPar (nested_compose_Expr show_thingies)))
952 data_con_RDR = qual_orig_name data_con
953 con_arity = dataConSourceArity data_con
954 bs_needed = take con_arity bs_RDRs
955 con_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
956 nullary_con = con_arity == 0
957 labels = dataConFieldLabels data_con
958 lab_fields = length labels
960 dc_nm = getName data_con
961 dc_occ_nm = getOccName data_con
962 dc_occ_nm_str = occNameUserString dc_occ_nm
964 is_infix = isDataSymOcc dc_occ_nm
968 | is_infix = mk_showString_app (' ':dc_occ_nm_str)
969 | otherwise = mk_showString_app (dc_occ_nm_str ++ space_ocurly_maybe)
973 | lab_fields == 0 = " "
977 show_all con fs@(x:xs)
978 | is_infix = x:con:xs
982 | lab_fields > 0 = [mk_showString_app "}"]
985 con:fs ++ ccurly_maybe
987 show_thingies = show_all show_con real_show_thingies_with_labs
989 show_label l = mk_showString_app (the_name ++ "=")
991 occ_nm = getOccName (fieldLabelName l)
993 is_op = isSymOcc occ_nm
995 | is_op = '(':nm ++ ")"
998 nm = occNameUserString occ_nm
1001 mk_showString_app str = HsApp (HsVar showString_RDR)
1002 (HsLit (mkHsString str))
1004 prec_cons = getLRPrecs is_infix gst dc_nm
1008 [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt p))) (HsVar b)
1009 | (p,b) <- zip prec_cons bs_needed ]
1011 [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
1014 real_show_thingies_with_labs
1015 | lab_fields == 0 = intersperse (HsVar showSpace_RDR) real_show_thingies
1016 | otherwise = --Assumption: no of fields == no of labelled fields
1017 -- (and in same order)
1019 intersperse ([mk_showString_app ","]) $ -- Using SLIT()s containing ,s spells trouble.
1020 zipWithEqual "gen_Show_binds"
1022 (map show_label labels)
1026 c.f. Figure 16 and 17 in Haskell 1.1 report
1029 | not is_infix = fromInt maxPrecedence + 1
1030 | otherwise = getFixity gst dc_nm + 1
1035 getLRPrecs :: Bool -> GlobalSymbolTable -> Name -> [Integer]
1036 getLRPrecs is_infix gst nm = [lp, rp]
1039 Figuring out the fixities of the arguments to a constructor,
1040 cf. Figures 16-18 in Haskell 1.1 report.
1042 (con_left_assoc, con_right_assoc) = isLRAssoc gst nm
1043 paren_con_prec = getFixity gst nm
1044 maxPrec = fromInt maxPrecedence
1047 | not is_infix = maxPrec + 1
1048 | con_left_assoc = paren_con_prec
1049 | otherwise = paren_con_prec + 1
1052 | not is_infix = maxPrec + 1
1053 | con_right_assoc = paren_con_prec
1054 | otherwise = paren_con_prec + 1
1056 getFixity :: GobalSymbolTable -> Name -> Integer
1057 getFixity gst nm = case lookupFixityEnv gst nm of
1058 Fixity x _ -> fromInt x
1060 isLRAssoc :: FixityEnv -> Name -> (Bool, Bool)
1061 isLRAssoc fixs_assoc nm =
1062 case lookupFixity fixs_assoc nm of
1063 Fixity _ InfixN -> (False, False)
1064 Fixity _ InfixR -> (False, True)
1065 Fixity _ InfixL -> (True, False)
1067 isInfixOccName :: String -> Bool
1068 isInfixOccName str =
1075 %************************************************************************
1077 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1079 %************************************************************************
1084 con2tag_Foo :: Foo ... -> Int#
1085 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1086 maxtag_Foo :: Int -- ditto (NB: not unboxed)
1089 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1094 = GenCon2Tag | GenTag2Con | GenMaxTag
1096 gen_tag_n_con_monobind
1097 :: (RdrName, -- (proto)Name for the thing in question
1098 TyCon, -- tycon in question
1102 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1103 | lots_of_constructors
1104 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1105 [([VarPatIn a_RDR], HsApp getTag_Expr a_Expr)]
1108 = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
1111 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1113 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
1115 = ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
1117 pat = ConPatIn var_RDR (nOfThem (dataConSourceArity var) WildPatIn)
1118 var_RDR = qual_orig_name var
1120 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1121 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1122 [([ConPatIn mkInt_RDR [VarPatIn a_RDR]],
1123 ExprWithTySig (HsApp tagToEnum_Expr a_Expr)
1124 (HsTyVar (qual_orig_name tycon)))]
1126 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1127 = mk_easy_FunMonoBind (getSrcLoc tycon)
1128 rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
1130 max_tag = case (tyConDataCons tycon) of
1131 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1135 %************************************************************************
1137 \subsection{Utility bits for generating bindings}
1139 %************************************************************************
1141 @mk_easy_FunMonoBind fun pats binds expr@ generates:
1143 fun pat1 pat2 ... patN = expr where binds
1146 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
1147 multi-clause definitions; it generates:
1149 fun p1a p1b ... p1N = e1
1150 fun p2a p2b ... p2N = e2
1152 fun pMa pMb ... pMN = eM
1156 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
1157 -> [RdrNameMonoBinds] -> RdrNameHsExpr
1160 mk_easy_FunMonoBind loc fun pats binds expr
1161 = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
1163 mk_easy_Match loc pats binds expr
1164 = mk_match loc pats expr (mkMonoBind (andMonoBindList binds) [] Recursive)
1165 -- The renamer expects everything in its input to be a
1166 -- "recursive" MonoBinds, and it is its job to sort things out
1169 mk_FunMonoBind :: SrcLoc -> RdrName
1170 -> [([RdrNamePat], RdrNameHsExpr)]
1173 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
1174 mk_FunMonoBind loc fun pats_and_exprs
1175 = FunMonoBind fun False{-not infix-}
1176 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
1179 mk_match loc pats expr binds
1180 = Match [] (map paren pats) Nothing
1181 (GRHSs (unguardedRHS expr loc) binds Nothing)
1183 paren p@(VarPatIn _) = p
1184 paren other_p = ParPatIn other_p
1188 mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
1191 ToDo: Better SrcLocs.
1195 RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1196 -> RdrNameHsExpr -> RdrNameHsExpr
1200 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1201 -> RdrNameHsExpr -> RdrNameHsExpr
1203 careful_compare_Case :: -- checks for primitive types...
1205 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1206 -> RdrNameHsExpr -> RdrNameHsExpr
1209 compare_Case = compare_gen_Case compare_RDR
1210 cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b
1211 -- Was: compare_gen_Case cmp_eq_RDR
1213 compare_gen_Case fun lt eq gt a b
1214 = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
1215 [mkSimpleMatch [ConPatIn ltTag_RDR []] lt Nothing mkGeneratedSrcLoc,
1216 mkSimpleMatch [ConPatIn eqTag_RDR []] eq Nothing mkGeneratedSrcLoc,
1217 mkSimpleMatch [ConPatIn gtTag_RDR []] gt Nothing mkGeneratedSrcLoc]
1220 careful_compare_Case ty lt eq gt a b
1221 = if not (isUnboxedType ty) then
1222 compare_gen_Case compare_RDR lt eq gt a b
1224 else -- we have to do something special for primitive things...
1225 HsIf (genOpApp a relevant_eq_op b)
1227 (HsIf (genOpApp a relevant_lt_op b) lt gt mkGeneratedSrcLoc)
1230 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1231 relevant_lt_op = assoc_ty_id lt_op_tbl ty
1233 assoc_ty_id tyids ty
1234 = if null res then panic "assoc_ty"
1237 res = [id | (ty',id) <- tyids, ty == ty']
1240 [(charPrimTy, eqH_Char_RDR)
1241 ,(intPrimTy, eqH_Int_RDR)
1242 ,(wordPrimTy, eqH_Word_RDR)
1243 ,(addrPrimTy, eqH_Addr_RDR)
1244 ,(floatPrimTy, eqH_Float_RDR)
1245 ,(doublePrimTy, eqH_Double_RDR)
1249 [(charPrimTy, ltH_Char_RDR)
1250 ,(intPrimTy, ltH_Int_RDR)
1251 ,(wordPrimTy, ltH_Word_RDR)
1252 ,(addrPrimTy, ltH_Addr_RDR)
1253 ,(floatPrimTy, ltH_Float_RDR)
1254 ,(doublePrimTy, ltH_Double_RDR)
1257 -----------------------------------------------------------------------
1259 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1261 and_Expr a b = genOpApp a and_RDR b
1262 append_Expr a b = genOpApp a append_RDR b
1264 -----------------------------------------------------------------------
1266 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1268 = if not (isUnboxedType ty) then
1270 else -- we have to do something special for primitive things...
1271 genOpApp a relevant_eq_op b
1273 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1277 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
1278 untag_Expr tycon [] expr = expr
1279 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1280 = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1281 [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) Nothing mkGeneratedSrcLoc]
1284 cmp_tags_Expr :: RdrName -- Comparison op
1285 -> RdrName -> RdrName -- Things to compare
1286 -> RdrNameHsExpr -- What to return if true
1287 -> RdrNameHsExpr -- What to return if false
1290 cmp_tags_Expr op a b true_case false_case
1291 = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case mkGeneratedSrcLoc
1294 :: RdrNameHsExpr -> RdrNameHsExpr
1296 enum_from_then_to_Expr
1297 :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1300 enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1301 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1303 showParen_Expr, readParen_Expr
1304 :: RdrNameHsExpr -> RdrNameHsExpr
1307 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1308 readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_RDR) e1) e2
1310 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1312 nested_compose_Expr [e] = parenify e
1313 nested_compose_Expr (e:es)
1314 = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1316 -- impossible_Expr is used in case RHSs that should never happen.
1317 -- We generate these to keep the desugarer from complaining that they *might* happen!
1318 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ "Urk! in TcGenDeriv")))
1320 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1321 -- method. It is currently only used by Enum.{succ,pred}
1322 illegal_Expr meth tp msg =
1323 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ (meth ++ '{':tp ++ "}: " ++ msg))))
1325 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1326 -- to include the value of a_RDR in the error string.
1327 illegal_toEnum_tag tp maxtag =
1328 HsApp (HsVar error_RDR)
1329 (HsApp (HsApp (HsVar append_RDR)
1330 (HsLit (HsString (_PK_ ("toEnum{" ++ tp ++ "}: tag (")))))
1331 (HsApp (HsApp (HsApp
1332 (HsVar showsPrec_RDR)
1337 (HsLit (HsString (_PK_ ") is outside of enumeration's range (0,"))))
1338 (HsApp (HsApp (HsApp
1339 (HsVar showsPrec_RDR)
1342 (HsLit (HsString (_PK_ ")")))))))
1344 parenify e@(HsVar _) = e
1345 parenify e = HsPar e
1347 -- genOpApp wraps brackets round the operator application, so that the
1348 -- renamer won't subsequently try to re-associate it.
1349 -- For some reason the renamer doesn't reassociate it right, and I can't
1350 -- be bothered to find out why just now.
1352 genOpApp e1 op e2 = mkHsOpApp e1 op e2
1356 qual_orig_name n = nameRdrName (getName n)
1357 varUnqual n = mkUnqual varName n
1359 zz_a_RDR = varUnqual SLIT("_a")
1360 a_RDR = varUnqual SLIT("a")
1361 b_RDR = varUnqual SLIT("b")
1362 c_RDR = varUnqual SLIT("c")
1363 d_RDR = varUnqual SLIT("d")
1364 ah_RDR = varUnqual SLIT("a#")
1365 bh_RDR = varUnqual SLIT("b#")
1366 ch_RDR = varUnqual SLIT("c#")
1367 dh_RDR = varUnqual SLIT("d#")
1368 cmp_eq_RDR = varUnqual SLIT("cmp_eq")
1369 rangeSize_RDR = varUnqual SLIT("rangeSize")
1371 as_RDRs = [ varUnqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
1372 bs_RDRs = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
1373 cs_RDRs = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
1375 mkHsString s = HsString (_PK_ s)
1377 zz_a_Expr = HsVar zz_a_RDR
1378 a_Expr = HsVar a_RDR
1379 b_Expr = HsVar b_RDR
1380 c_Expr = HsVar c_RDR
1381 d_Expr = HsVar d_RDR
1382 ltTag_Expr = HsVar ltTag_RDR
1383 eqTag_Expr = HsVar eqTag_RDR
1384 gtTag_Expr = HsVar gtTag_RDR
1385 false_Expr = HsVar false_RDR
1386 true_Expr = HsVar true_RDR
1388 getTag_Expr = HsVar getTag_RDR
1389 tagToEnum_Expr = HsVar tagToEnumH_RDR
1390 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1393 zz_a_Pat = VarPatIn zz_a_RDR
1394 a_Pat = VarPatIn a_RDR
1395 b_Pat = VarPatIn b_RDR
1396 c_Pat = VarPatIn c_RDR
1397 d_Pat = VarPatIn d_RDR
1399 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1401 con2tag_RDR tycon = varUnqual (_PK_ ("con2tag_" ++ occNameString (getOccName tycon) ++ "#"))
1402 tag2con_RDR tycon = varUnqual (_PK_ ("tag2con_" ++ occNameString (getOccName tycon) ++ "#"))
1403 maxtag_RDR tycon = varUnqual (_PK_ ("maxtag_" ++ occNameString (getOccName tycon) ++ "#"))