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 , maxPrecedence, defaultFixity
40 import FieldLabel ( fieldLabelName )
41 import DataCon ( isNullaryDataCon, dataConTag,
42 dataConRawArgTys, fIRST_TAG,
45 import Name ( getOccString, getOccName, getSrcLoc, occNameString,
46 occNameUserString, nameRdrName, varName,
47 OccName, Name, NamedThing(..), NameSpace,
48 isDataSymOcc, isSymOcc
51 import PrimOp ( PrimOp(..) )
52 import PrelInfo -- Lots of RdrNames
53 import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
54 import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
55 maybeTyConSingleCon, tyConFamilySize
57 import Type ( isUnLiftedType, isUnboxedType, Type )
58 import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
59 floatPrimTy, doublePrimTy
61 import Util ( mapAccumL, zipEqual, zipWithEqual,
62 zipWith3Equal, nOfThem, assocDefault )
63 import Panic ( panic, assertPanic )
64 import Maybes ( maybeToBool )
66 import List ( partition, intersperse )
67 import Char ( isAlpha )
69 #if __GLASGOW_HASKELL__ >= 404
70 import GlaExts ( fromInt )
74 %************************************************************************
76 \subsection{Generating code, by derivable class}
78 %************************************************************************
80 %************************************************************************
82 \subsubsection{Generating @Eq@ instance declarations}
84 %************************************************************************
86 Here are the heuristics for the code we generate for @Eq@:
89 Let's assume we have a data type with some (possibly zero) nullary
90 data constructors and some ordinary, non-nullary ones (the rest,
91 also possibly zero of them). Here's an example, with both \tr{N}ullary
92 and \tr{O}rdinary data cons.
94 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
98 For the ordinary constructors (if any), we emit clauses to do The
102 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
103 (==) (O2 a1) (O2 a2) = a1 == a2
104 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
107 Note: if we're comparing unboxed things, e.g., if \tr{a1} and
108 \tr{a2} are \tr{Float#}s, then we have to generate
110 case (a1 `eqFloat#` a2) of
113 for that particular test.
116 If there are any nullary constructors, we emit a catch-all clause of
120 (==) a b = case (con2tag_Foo a) of { a# ->
121 case (con2tag_Foo b) of { b# ->
122 case (a# ==# b#) of {
127 If there aren't any nullary constructors, we emit a simpler
134 For the @(/=)@ method, we normally just use the default method.
136 If the type is an enumeration type, we could/may/should? generate
137 special code that calls @con2tag_Foo@, much like for @(==)@ shown
141 We thought about doing this: If we're also deriving @Ord@ for this
144 instance ... Eq (Foo ...) where
145 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
146 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
148 However, that requires that \tr{Ord <whatever>} was put in the context
149 for the instance decl, which it probably wasn't, so the decls
150 produced don't get through the typechecker.
154 deriveEq :: RdrName -- Class
155 -> RdrName -- Type constructor
156 -> [ (RdrName, [RdrType]) ] -- Constructors
157 -> (RdrContext, -- Context for the inst decl
158 [RdrBind], -- Binds in the inst decl
159 [RdrBind]) -- Extra value bindings outside
161 deriveEq clas tycon constrs
162 = (context, [eq_bind, ne_bind], [])
164 context = [(clas, [ty]) | (_, tys) <- constrs, ty <- tys]
167 (nullary_cons, non_nullary_cons) = partition is_nullary constrs
168 is_nullary (_, args) = null args
171 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
175 tycon_loc = getSrcLoc tycon
176 (nullary_cons, nonnullary_cons)
177 | isNewTyCon tycon = ([], tyConDataCons tycon)
178 | otherwise = partition isNullaryDataCon (tyConDataCons tycon)
181 = if (null nullary_cons) then
182 case maybeTyConSingleCon tycon of
184 Nothing -> -- if cons don't match, then False
185 [([wildPat, wildPat], false_Expr)]
186 else -- calc. and compare the tags
188 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
189 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR true_Expr false_Expr))]
191 mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
193 mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
194 HsApp (HsVar not_RDR) (HsPar (mk_easy_App eq_RDR [a_RDR, b_RDR])))
196 ------------------------------------------------------------------
199 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
200 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
202 data_con_RDR = qual_orig_name data_con
203 con_arity = length tys_needed
204 as_needed = take con_arity as_RDRs
205 bs_needed = take con_arity bs_RDRs
206 tys_needed = dataConRawArgTys data_con
208 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
210 nested_eq_expr [] [] [] = true_Expr
211 nested_eq_expr tys as bs
212 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
214 nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
217 %************************************************************************
219 \subsubsection{Generating @Ord@ instance declarations}
221 %************************************************************************
223 For a derived @Ord@, we concentrate our attentions on @compare@
225 compare :: a -> a -> Ordering
226 data Ordering = LT | EQ | GT deriving ()
229 We will use the same example data type as above:
231 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
236 We do all the other @Ord@ methods with calls to @compare@:
238 instance ... (Ord <wurble> <wurble>) where
239 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
240 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
241 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
242 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
244 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
245 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
247 -- compare to come...
251 @compare@ always has two parts. First, we use the compared
252 data-constructors' tags to deal with the case of different
255 compare a b = case (con2tag_Foo a) of { a# ->
256 case (con2tag_Foo b) of { b# ->
257 case (a# ==# b#) of {
259 False -> case (a# <# b#) of
264 cmp_eq = ... to come ...
268 We are only left with the ``help'' function @cmp_eq@, to deal with
269 comparing data constructors with the same tag.
271 For the ordinary constructors (if any), we emit the sorta-obvious
272 compare-style stuff; for our example:
274 cmp_eq (O1 a1 b1) (O1 a2 b2)
275 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
277 cmp_eq (O2 a1) (O2 a2)
280 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
281 = case (compare a1 a2) of {
284 EQ -> case compare b1 b2 of {
292 Again, we must be careful about unboxed comparisons. For example,
293 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
297 cmp_eq lt eq gt (O2 a1) (O2 a2)
299 -- or maybe the unfolded equivalent
303 For the remaining nullary constructors, we already know that the
310 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
314 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
317 = compare -- `AndMonoBinds` compare
318 -- The default declaration in PrelBase handles this
320 tycon_loc = getSrcLoc tycon
321 --------------------------------------------------------------------
322 compare = mk_easy_FunMonoBind tycon_loc compare_RDR
325 (if maybeToBool (maybeTyConSingleCon tycon) then
327 -- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
328 -- Wierd. Was: case (cmp a b) of { LT -> LT; EQ -> EQ; GT -> GT }
330 cmp_eq_Expr a_Expr b_Expr
332 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
333 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR
334 -- True case; they are equal
335 -- If an enumeration type we are done; else
336 -- recursively compare their components
337 (if isEnumerationTyCon tycon then
340 -- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
342 cmp_eq_Expr a_Expr b_Expr
344 -- False case; they aren't equal
345 -- So we need to do a less-than comparison on the tags
346 (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
348 tycon_data_cons = tyConDataCons tycon
349 (nullary_cons, nonnullary_cons)
350 | isNewTyCon tycon = ([], tyConDataCons tycon)
351 | otherwise = partition isNullaryDataCon tycon_data_cons
354 mk_FunMonoBind tycon_loc
356 (if null nonnullary_cons && (length nullary_cons == 1) then
357 -- catch this specially to avoid warnings
358 -- about overlapping patterns from the desugarer.
360 data_con = head nullary_cons
361 data_con_RDR = qual_orig_name data_con
362 pat = ConPatIn data_con_RDR []
364 [([pat,pat], eqTag_Expr)]
366 map pats_etc nonnullary_cons ++
367 -- leave out wildcards to silence desugarer.
368 (if length tycon_data_cons == 1 then
371 [([WildPatIn, WildPatIn], default_rhs)]))
374 = ([con1_pat, con2_pat],
375 nested_compare_expr tys_needed as_needed bs_needed)
377 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
378 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
380 data_con_RDR = qual_orig_name data_con
381 con_arity = length tys_needed
382 as_needed = take con_arity as_RDRs
383 bs_needed = take con_arity bs_RDRs
384 tys_needed = dataConRawArgTys data_con
386 nested_compare_expr [ty] [a] [b]
387 = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
389 nested_compare_expr (ty:tys) (a:as) (b:bs)
390 = let eq_expr = nested_compare_expr tys as bs
391 in careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
393 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
394 -- inexhaustive patterns
395 | otherwise = eqTag_Expr -- Some nullary constructors;
396 -- Tags are equal, no args => return EQ
397 --------------------------------------------------------------------
399 {- Not necessary: the default decls in PrelBase handle these
401 defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
403 lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] (
404 compare_Case true_Expr false_Expr false_Expr a_Expr b_Expr)
405 le = mk_easy_FunMonoBind mkGeneratedSrcLoc le_RDR [a_Pat, b_Pat] [] (
406 compare_Case true_Expr true_Expr false_Expr a_Expr b_Expr)
407 ge = mk_easy_FunMonoBind mkGeneratedSrcLoc ge_RDR [a_Pat, b_Pat] [] (
408 compare_Case false_Expr true_Expr true_Expr a_Expr b_Expr)
409 gt = mk_easy_FunMonoBind mkGeneratedSrcLoc gt_RDR [a_Pat, b_Pat] [] (
410 compare_Case false_Expr false_Expr true_Expr a_Expr b_Expr)
412 max_ = mk_easy_FunMonoBind mkGeneratedSrcLoc max_RDR [a_Pat, b_Pat] [] (
413 compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
414 min_ = mk_easy_FunMonoBind mkGeneratedSrcLoc min_RDR [a_Pat, b_Pat] [] (
415 compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
419 %************************************************************************
421 \subsubsection{Generating @Enum@ instance declarations}
423 %************************************************************************
425 @Enum@ can only be derived for enumeration types. For a type
427 data Foo ... = N1 | N2 | ... | Nn
430 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
431 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
434 instance ... Enum (Foo ...) where
435 succ x = toEnum (1 + fromEnum x)
436 pred x = toEnum (fromEnum x - 1)
438 toEnum i = tag2con_Foo i
440 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
444 = case con2tag_Foo a of
445 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
448 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
452 = case con2tag_Foo a of { a# ->
453 case con2tag_Foo b of { b# ->
454 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
458 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
461 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
464 = succ_enum `AndMonoBinds`
465 pred_enum `AndMonoBinds`
466 to_enum `AndMonoBinds`
467 enum_from `AndMonoBinds`
468 enum_from_then `AndMonoBinds`
471 tycon_loc = getSrcLoc tycon
472 occ_nm = getOccString tycon
475 = mk_easy_FunMonoBind tycon_loc succ_RDR [a_Pat] [] $
476 untag_Expr tycon [(a_RDR, ah_RDR)] $
477 HsIf (HsApp (HsApp (HsVar eq_RDR)
478 (HsVar (maxtag_RDR tycon)))
479 (mk_easy_App mkInt_RDR [ah_RDR]))
480 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
481 (HsApp (HsVar (tag2con_RDR tycon))
482 (HsApp (HsApp (HsVar plus_RDR)
483 (mk_easy_App mkInt_RDR [ah_RDR]))
488 = mk_easy_FunMonoBind tycon_loc pred_RDR [a_Pat] [] $
489 untag_Expr tycon [(a_RDR, ah_RDR)] $
490 HsIf (HsApp (HsApp (HsVar eq_RDR) (HsLit (HsInt 0)))
491 (mk_easy_App mkInt_RDR [ah_RDR]))
492 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
493 (HsApp (HsVar (tag2con_RDR tycon))
494 (HsApp (HsApp (HsVar plus_RDR)
495 (mk_easy_App mkInt_RDR [ah_RDR]))
496 (HsLit (HsInt (-1)))))
500 = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
503 (HsApp (HsApp (HsVar ge_RDR)
506 (HsApp (HsApp (HsVar le_RDR)
508 (HsVar (maxtag_RDR tycon))))
509 (mk_easy_App (tag2con_RDR tycon) [a_RDR])
510 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
514 = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
515 untag_Expr tycon [(a_RDR, ah_RDR)] $
516 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
517 HsPar (enum_from_to_Expr
518 (mk_easy_App mkInt_RDR [ah_RDR])
519 (HsVar (maxtag_RDR tycon)))
522 = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
523 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
524 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
525 HsPar (enum_from_then_to_Expr
526 (mk_easy_App mkInt_RDR [ah_RDR])
527 (mk_easy_App mkInt_RDR [bh_RDR])
528 (HsIf (HsApp (HsApp (HsVar gt_RDR)
529 (mk_easy_App mkInt_RDR [ah_RDR]))
530 (mk_easy_App mkInt_RDR [bh_RDR]))
532 (HsVar (maxtag_RDR tycon))
536 = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
537 untag_Expr tycon [(a_RDR, ah_RDR)] $
538 (mk_easy_App mkInt_RDR [ah_RDR])
541 %************************************************************************
543 \subsubsection{Generating @Bounded@ instance declarations}
545 %************************************************************************
548 gen_Bounded_binds tycon
549 = if isEnumerationTyCon tycon then
550 min_bound_enum `AndMonoBinds` max_bound_enum
552 ASSERT(length data_cons == 1)
553 min_bound_1con `AndMonoBinds` max_bound_1con
555 data_cons = tyConDataCons tycon
556 tycon_loc = getSrcLoc tycon
558 ----- enum-flavored: ---------------------------
559 min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
560 max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR)
562 data_con_1 = head data_cons
563 data_con_N = last data_cons
564 data_con_1_RDR = qual_orig_name data_con_1
565 data_con_N_RDR = qual_orig_name data_con_N
567 ----- single-constructor-flavored: -------------
568 arity = argFieldCount data_con_1
570 min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
571 mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
572 max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
573 mk_easy_App data_con_1_RDR (nOfThem arity maxBound_RDR)
576 %************************************************************************
578 \subsubsection{Generating @Ix@ instance declarations}
580 %************************************************************************
582 Deriving @Ix@ is only possible for enumeration types and
583 single-constructor types. We deal with them in turn.
585 For an enumeration type, e.g.,
587 data Foo ... = N1 | N2 | ... | Nn
589 things go not too differently from @Enum@:
591 instance ... Ix (Foo ...) where
593 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
597 = case (con2tag_Foo a) of { a# ->
598 case (con2tag_Foo b) of { b# ->
599 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
604 then case (con2tag_Foo d -# con2tag_Foo a) of
606 else error "Ix.Foo.index: out of range"
610 p_tag = con2tag_Foo c
612 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
616 = case (con2tag_Foo a) of { a_tag ->
617 case (con2tag_Foo b) of { b_tag ->
618 case (con2tag_Foo c) of { c_tag ->
619 if (c_tag >=# a_tag) then
625 (modulo suitable case-ification to handle the unboxed tags)
627 For a single-constructor type (NB: this includes all tuples), e.g.,
629 data Foo ... = MkFoo a b Int Double c c
631 we follow the scheme given in Figure~19 of the Haskell~1.2 report
635 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
638 = if isEnumerationTyCon tycon
642 tycon_str = getOccString tycon
643 tycon_loc = getSrcLoc tycon
645 --------------------------------------------------------------
646 enum_ixes = enum_range `AndMonoBinds`
647 enum_index `AndMonoBinds` enum_inRange
650 = mk_easy_FunMonoBind tycon_loc range_RDR
651 [TuplePatIn [a_Pat, b_Pat] True{-boxed-}] [] $
652 untag_Expr tycon [(a_RDR, ah_RDR)] $
653 untag_Expr tycon [(b_RDR, bh_RDR)] $
654 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
655 HsPar (enum_from_to_Expr
656 (mk_easy_App mkInt_RDR [ah_RDR])
657 (mk_easy_App mkInt_RDR [bh_RDR]))
660 = mk_easy_FunMonoBind tycon_loc index_RDR
661 [AsPatIn c_RDR (TuplePatIn [a_Pat, wildPat] True{-boxed-}),
663 HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
664 untag_Expr tycon [(a_RDR, ah_RDR)] (
665 untag_Expr tycon [(d_RDR, dh_RDR)] (
667 rhs = mk_easy_App mkInt_RDR [c_RDR]
670 (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
671 [mkSimpleMatch [VarPatIn c_RDR] rhs Nothing tycon_loc]
675 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
680 = mk_easy_FunMonoBind tycon_loc inRange_RDR
681 [TuplePatIn [a_Pat, b_Pat] True{-boxed-}, c_Pat] [] (
682 untag_Expr tycon [(a_RDR, ah_RDR)] (
683 untag_Expr tycon [(b_RDR, bh_RDR)] (
684 untag_Expr tycon [(c_RDR, ch_RDR)] (
685 HsIf (genOpApp (HsVar ch_RDR) geH_RDR (HsVar ah_RDR)) (
686 (genOpApp (HsVar ch_RDR) leH_RDR (HsVar bh_RDR))
691 --------------------------------------------------------------
693 = single_con_range `AndMonoBinds`
694 single_con_index `AndMonoBinds`
698 = case maybeTyConSingleCon tycon of -- just checking...
699 Nothing -> panic "get_Ix_binds"
700 Just dc -> if (any isUnLiftedType (dataConRawArgTys dc)) then
701 error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
705 con_arity = argFieldCount data_con
706 data_con_RDR = qual_orig_name data_con
708 as_needed = take con_arity as_RDRs
709 bs_needed = take con_arity bs_RDRs
710 cs_needed = take con_arity cs_RDRs
712 con_pat xs = ConPatIn data_con_RDR (map VarPatIn xs)
713 con_expr = mk_easy_App data_con_RDR cs_needed
715 --------------------------------------------------------------
717 = mk_easy_FunMonoBind tycon_loc range_RDR
718 [TuplePatIn [con_pat as_needed, con_pat bs_needed] True{-boxed-}] [] $
719 HsDo ListComp stmts tycon_loc
721 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
723 [ReturnStmt con_expr]
725 mk_qual a b c = BindStmt (VarPatIn c)
726 (HsApp (HsVar range_RDR)
727 (ExplicitTuple [HsVar a, HsVar b] True))
732 = mk_easy_FunMonoBind tycon_loc index_RDR
733 [TuplePatIn [con_pat as_needed, con_pat bs_needed] True,
734 con_pat cs_needed] [range_size] (
735 foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
737 mk_index multiply_by (l, u, i)
739 (HsApp (HsApp (HsVar index_RDR)
740 (ExplicitTuple [HsVar l, HsVar u] True)) (HsVar i))
743 (HsApp (HsVar rangeSize_RDR)
744 (ExplicitTuple [HsVar l, HsVar u] True))
745 ) times_RDR multiply_by
749 = mk_easy_FunMonoBind tycon_loc rangeSize_RDR
750 [TuplePatIn [a_Pat, b_Pat] True] [] (
752 (HsApp (HsApp (HsVar index_RDR)
753 (ExplicitTuple [a_Expr, b_Expr] True)) b_Expr)
754 ) plus_RDR (HsLit (HsInt 1)))
758 = mk_easy_FunMonoBind tycon_loc inRange_RDR
759 [TuplePatIn [con_pat as_needed, con_pat bs_needed] True,
762 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
764 in_range a b c = HsApp (HsApp (HsVar inRange_RDR)
765 (ExplicitTuple [HsVar a, HsVar b] True))
769 %************************************************************************
771 \subsubsection{Generating @Read@ instance declarations}
773 %************************************************************************
776 gen_Read_binds :: Fixities -> TyCon -> RdrNameMonoBinds
778 gen_Read_binds fixities tycon
779 = reads_prec `AndMonoBinds` read_list
781 tycon_loc = getSrcLoc tycon
782 -----------------------------------------------------------------------
783 read_list = mk_easy_FunMonoBind tycon_loc readList_RDR [] []
784 (HsApp (HsVar readList___RDR) (HsPar (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 0)))))
785 -----------------------------------------------------------------------
788 read_con_comprehensions
789 = map read_con (tyConDataCons tycon)
791 mk_easy_FunMonoBind tycon_loc readsPrec_RDR [zz_a_Pat, b_Pat] [] (
792 foldr1 append_Expr read_con_comprehensions
795 read_con data_con -- note: "b" is the string being "read"
797 readParen_Expr read_paren_arg $ HsPar $
798 HsLam (mk_easy_Match tycon_loc [c_Pat] [] $
799 HsDo ListComp stmts tycon_loc)
802 data_con_RDR = qual_orig_name data_con
803 data_con_str = occNameUserString (getOccName data_con)
804 con_arity = argFieldCount data_con
805 con_expr = mk_easy_App data_con_RDR as_needed
806 nullary_con = con_arity == 0
807 labels = dataConFieldLabels data_con
808 lab_fields = length labels
809 dc_nm = getName data_con
810 is_infix = isDataSymOcc (getOccName dc_nm)
812 as_needed = take con_arity as_RDRs
814 | is_infix = take (1 + con_arity) bs_RDRs
815 | lab_fields == 0 = take con_arity bs_RDRs
816 | otherwise = take (4*lab_fields + 1) bs_RDRs
817 -- (label, '=' and field)*n, (n-1)*',' + '{' + '}'
819 (as1:as2:_) = as_needed
820 (bs1:bs2:bs3:_) = bs_needed
825 (TuplePatIn [LitPatIn (mkHsString data_con_str), d_Pat] True)
826 (HsApp (HsVar lex_RDR) c_Expr)
830 (TuplePatIn [LitPatIn (mkHsString data_con_str), VarPatIn bs2] True)
831 (HsApp (HsVar lex_RDR) (HsVar bs1))
835 str_qual str res draw_from =
837 (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] True)
838 (HsApp (HsVar lex_RDR) draw_from)
841 str_qual_paren str res draw_from =
843 (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] True)
844 (HsApp (readParen_Expr true_Expr (HsVar lex_RDR)) draw_from)
847 read_label f = [rd_lab, str_qual "="]
848 -- There might be spaces between the label and '='
851 | is_op = str_qual_paren nm
852 | otherwise = str_qual nm
854 occ_nm = getOccName (fieldLabelName f)
855 is_op = isSymOcc occ_nm
856 nm = occNameUserString occ_nm
860 snd (mapAccumL mk_qual_infix
862 [ (mk_read_qual lp as1, bs1, bs2)
863 , (mk_read_qual rp as2, bs3, bs3)
865 | lab_fields == 0 = -- common case.
866 snd (mapAccumL mk_qual
868 (zipWithEqual "as_needed"
869 (\ con_field draw_from -> (mk_read_qual 10 con_field,
871 as_needed bs_needed))
874 mapAccumL mk_qual d_Expr
875 (zipEqual "bs_needed"
878 intersperse [str_qual ","] $
881 (\ as b -> as ++ [b])
883 (map read_label labels)
885 (map (mk_read_qual 10) as_needed))) ++ [str_qual "}"])
888 mk_qual_infix draw_from (f, str_left, str_left2) =
889 (HsVar str_left2, -- what to draw from down the line...
890 f str_left draw_from)
892 mk_qual draw_from (f, str_left) =
893 (HsVar str_left, -- what to draw from down the line...
894 f str_left draw_from)
896 mk_read_qual p con_field res draw_from =
898 (TuplePatIn [VarPatIn con_field, VarPatIn res] True)
899 (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt p))) draw_from)
902 result_expr = ExplicitTuple [con_expr, if null bs_needed
904 else HsVar (last bs_needed)] True
906 [lp,rp] = getLRPrecs is_infix fixities dc_nm
909 | is_infix = let (h:t) = field_quals in (h:con_qual:t)
910 | otherwise = con_qual:field_quals
912 stmts = quals ++ [ReturnStmt result_expr]
915 c.f. Figure 18 in Haskell 1.1 report.
918 | not is_infix = fromInt maxPrecedence
919 | otherwise = getFixity fixities dc_nm
921 read_paren_arg -- parens depend on precedence...
922 | nullary_con = false_Expr -- it's optional.
923 | otherwise = HsPar (genOpApp zz_a_Expr gt_RDR (HsLit (HsInt paren_prec_limit)))
926 %************************************************************************
928 \subsubsection{Generating @Show@ instance declarations}
930 %************************************************************************
933 gen_Show_binds :: Fixities -> TyCon -> RdrNameMonoBinds
935 gen_Show_binds fixs_assoc tycon
936 = shows_prec `AndMonoBinds` show_list
938 tycon_loc = getSrcLoc tycon
939 -----------------------------------------------------------------------
940 show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
941 (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 0)))))
942 -----------------------------------------------------------------------
943 shows_prec = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
946 | nullary_con = -- skip the showParen junk...
947 ASSERT(null bs_needed)
948 ([wildPat, con_pat], show_con)
951 showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt paren_prec_limit))))
952 (HsPar (nested_compose_Expr show_thingies)))
954 data_con_RDR = qual_orig_name data_con
955 con_arity = argFieldCount data_con
956 bs_needed = take con_arity bs_RDRs
957 con_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
958 nullary_con = con_arity == 0
959 labels = dataConFieldLabels data_con
960 lab_fields = length labels
962 dc_nm = getName data_con
963 dc_occ_nm = getOccName data_con
964 dc_occ_nm_str = occNameUserString dc_occ_nm
966 is_infix = isDataSymOcc dc_occ_nm
970 | is_infix = mk_showString_app (' ':dc_occ_nm_str)
971 | otherwise = mk_showString_app (dc_occ_nm_str ++ space_ocurly_maybe)
975 | lab_fields == 0 = " "
979 show_all con fs@(x:xs)
980 | is_infix = x:con:xs
984 | lab_fields > 0 = [mk_showString_app "}"]
987 con:fs ++ ccurly_maybe
989 show_thingies = show_all show_con real_show_thingies_with_labs
991 show_label l = mk_showString_app (the_name ++ "=")
993 occ_nm = getOccName (fieldLabelName l)
995 is_op = isSymOcc occ_nm
997 | is_op = '(':nm ++ ")"
1000 nm = occNameUserString occ_nm
1003 mk_showString_app str = HsApp (HsVar showString_RDR)
1004 (HsLit (mkHsString str))
1006 prec_cons = getLRPrecs is_infix fixs_assoc dc_nm
1010 [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt p))) (HsVar b)
1011 | (p,b) <- zip prec_cons bs_needed ]
1013 [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
1016 real_show_thingies_with_labs
1017 | lab_fields == 0 = intersperse (HsVar showSpace_RDR) real_show_thingies
1018 | otherwise = --Assumption: no of fields == no of labelled fields
1019 -- (and in same order)
1021 intersperse ([mk_showString_app ","]) $ -- Using SLIT()s containing ,s spells trouble.
1022 zipWithEqual "gen_Show_binds"
1024 (map show_label labels)
1027 (con_left_assoc, con_right_assoc) = isLRAssoc fixs_assoc dc_nm
1030 c.f. Figure 16 and 17 in Haskell 1.1 report
1033 | not is_infix = fromInt maxPrecedence + 1
1034 | otherwise = getFixity fixs_assoc dc_nm + 1
1039 getLRPrecs :: Bool -> Fixities -> Name -> [Integer]
1040 getLRPrecs is_infix fixs_assoc nm = [lp, rp]
1043 Figuring out the fixities of the arguments to a constructor,
1044 cf. Figures 16-18 in Haskell 1.1 report.
1046 (con_left_assoc, con_right_assoc) = isLRAssoc fixs_assoc nm
1047 paren_con_prec = getFixity fixs_assoc nm
1048 maxPrec = fromInt maxPrecedence
1051 | not is_infix = maxPrec + 1
1052 | con_left_assoc = paren_con_prec
1053 | otherwise = paren_con_prec + 1
1056 | not is_infix = maxPrec + 1
1057 | con_right_assoc = paren_con_prec
1058 | otherwise = paren_con_prec + 1
1060 getFixity :: Fixities -> Name -> Integer
1061 getFixity fixs_assoc nm =
1062 case lookupFixity fixs_assoc nm of
1063 Fixity x _ -> fromInt x
1065 isLRAssoc :: Fixities -> Name -> (Bool, Bool)
1066 isLRAssoc fixs_assoc nm =
1067 case lookupFixity fixs_assoc nm of
1068 Fixity _ InfixN -> (False, False)
1069 Fixity _ InfixR -> (False, True)
1070 Fixity _ InfixL -> (True, False)
1072 lookupFixity :: Fixities -> Name -> Fixity
1073 lookupFixity fixs_assoc nm = assocDefault defaultFixity fixs_assoc nm
1075 isInfixOccName :: String -> Bool
1076 isInfixOccName str =
1084 %************************************************************************
1086 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1088 %************************************************************************
1093 con2tag_Foo :: Foo ... -> Int#
1094 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1095 maxtag_Foo :: Int -- ditto (NB: not unboxed)
1098 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1103 = GenCon2Tag | GenTag2Con | GenMaxTag
1105 gen_tag_n_con_monobind
1106 :: (RdrName, -- (proto)Name for the thing in question
1107 TyCon, -- tycon in question
1111 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1112 | lots_of_constructors
1113 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1114 [([VarPatIn a_RDR], HsApp getTag_Expr a_Expr)]
1117 = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
1120 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1122 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
1124 = ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
1126 pat = ConPatIn var_RDR (nOfThem (argFieldCount var) WildPatIn)
1127 var_RDR = qual_orig_name var
1129 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1130 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1131 [([ConPatIn mkInt_RDR [VarPatIn a_RDR]],
1132 ExprWithTySig (HsApp tagToEnum_Expr a_Expr)
1133 (MonoTyVar (qual_orig_name tycon)))]
1135 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1136 = mk_easy_FunMonoBind (getSrcLoc tycon)
1137 rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
1139 max_tag = case (tyConDataCons tycon) of
1140 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1144 %************************************************************************
1146 \subsection{Utility bits for generating bindings}
1148 %************************************************************************
1150 @mk_easy_FunMonoBind fun pats binds expr@ generates:
1152 fun pat1 pat2 ... patN = expr where binds
1155 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
1156 multi-clause definitions; it generates:
1158 fun p1a p1b ... p1N = e1
1159 fun p2a p2b ... p2N = e2
1161 fun pMa pMb ... pMN = eM
1165 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
1166 -> [RdrNameMonoBinds] -> RdrNameHsExpr
1169 mk_easy_FunMonoBind loc fun pats binds expr
1170 = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
1172 mk_easy_Match loc pats binds expr
1173 = mk_match loc pats expr (mkbind binds)
1175 mkbind [] = EmptyBinds
1176 mkbind bs = MonoBind (foldr1 AndMonoBinds bs) [] Recursive
1177 -- The renamer expects everything in its input to be a
1178 -- "recursive" MonoBinds, and it is its job to sort things out
1181 mk_FunMonoBind :: SrcLoc -> RdrName
1182 -> [([RdrNamePat], RdrNameHsExpr)]
1185 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
1186 mk_FunMonoBind loc fun pats_and_exprs
1187 = FunMonoBind fun False{-not infix-}
1188 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
1191 mk_match loc pats expr binds
1192 = Match [] (map paren pats) Nothing
1193 (GRHSs (unguardedRHS expr loc) binds Nothing)
1195 paren p@(VarPatIn _) = p
1196 paren other_p = ParPatIn other_p
1200 mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
1203 ToDo: Better SrcLocs.
1207 RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1208 -> RdrNameHsExpr -> RdrNameHsExpr
1212 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1213 -> RdrNameHsExpr -> RdrNameHsExpr
1215 careful_compare_Case :: -- checks for primitive types...
1217 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1218 -> RdrNameHsExpr -> RdrNameHsExpr
1221 compare_Case = compare_gen_Case compare_RDR
1222 cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b
1223 -- Was: compare_gen_Case cmp_eq_RDR
1225 compare_gen_Case fun lt eq gt a b
1226 = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
1227 [mkSimpleMatch [ConPatIn ltTag_RDR []] lt Nothing mkGeneratedSrcLoc,
1228 mkSimpleMatch [ConPatIn eqTag_RDR []] eq Nothing mkGeneratedSrcLoc,
1229 mkSimpleMatch [ConPatIn gtTag_RDR []] gt Nothing mkGeneratedSrcLoc]
1232 careful_compare_Case ty lt eq gt a b
1233 = if not (isUnboxedType ty) then
1234 compare_gen_Case compare_RDR lt eq gt a b
1236 else -- we have to do something special for primitive things...
1237 HsIf (genOpApp a relevant_eq_op b)
1239 (HsIf (genOpApp a relevant_lt_op b) lt gt mkGeneratedSrcLoc)
1242 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1243 relevant_lt_op = assoc_ty_id lt_op_tbl ty
1245 assoc_ty_id tyids ty
1246 = if null res then panic "assoc_ty"
1249 res = [id | (ty',id) <- tyids, ty == ty']
1252 [(charPrimTy, eqH_Char_RDR)
1253 ,(intPrimTy, eqH_Int_RDR)
1254 ,(wordPrimTy, eqH_Word_RDR)
1255 ,(addrPrimTy, eqH_Addr_RDR)
1256 ,(floatPrimTy, eqH_Float_RDR)
1257 ,(doublePrimTy, eqH_Double_RDR)
1261 [(charPrimTy, ltH_Char_RDR)
1262 ,(intPrimTy, ltH_Int_RDR)
1263 ,(wordPrimTy, ltH_Word_RDR)
1264 ,(addrPrimTy, ltH_Addr_RDR)
1265 ,(floatPrimTy, ltH_Float_RDR)
1266 ,(doublePrimTy, ltH_Double_RDR)
1269 -----------------------------------------------------------------------
1271 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1273 and_Expr a b = genOpApp a and_RDR b
1274 append_Expr a b = genOpApp a append_RDR b
1276 -----------------------------------------------------------------------
1278 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1280 = if not (isUnboxedType ty) then
1282 else -- we have to do something special for primitive things...
1283 genOpApp a relevant_eq_op b
1285 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1289 argFieldCount :: DataCon -> Int -- Works on data and newtype constructors
1290 argFieldCount con = length (dataConRawArgTys con)
1294 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
1295 untag_Expr tycon [] expr = expr
1296 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1297 = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1298 [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) Nothing mkGeneratedSrcLoc]
1301 cmp_tags_Expr :: RdrName -- Comparison op
1302 -> RdrName -> RdrName -- Things to compare
1303 -> RdrNameHsExpr -- What to return if true
1304 -> RdrNameHsExpr -- What to return if false
1307 cmp_tags_Expr op a b true_case false_case
1308 = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case mkGeneratedSrcLoc
1311 :: RdrNameHsExpr -> RdrNameHsExpr
1313 enum_from_then_to_Expr
1314 :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1317 enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1318 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1320 showParen_Expr, readParen_Expr
1321 :: RdrNameHsExpr -> RdrNameHsExpr
1324 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1325 readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_RDR) e1) e2
1327 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1329 nested_compose_Expr [e] = parenify e
1330 nested_compose_Expr (e:es)
1331 = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1333 -- impossible_Expr is used in case RHSs that should never happen.
1334 -- We generate these to keep the desugarer from complaining that they *might* happen!
1335 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ "Urk! in TcGenDeriv")))
1337 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1338 -- method. It is currently only used by Enum.{succ,pred}
1339 illegal_Expr meth tp msg =
1340 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ (meth ++ '{':tp ++ "}: " ++ msg))))
1342 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1343 -- to include the value of a_RDR in the error string.
1344 illegal_toEnum_tag tp maxtag =
1345 HsApp (HsVar error_RDR)
1346 (HsApp (HsApp (HsVar append_RDR)
1347 (HsLit (HsString (_PK_ ("toEnum{" ++ tp ++ "}: tag (")))))
1348 (HsApp (HsApp (HsApp
1349 (HsVar showsPrec_RDR)
1354 (HsLit (HsString (_PK_ ") is outside of enumeration's range (0,"))))
1355 (HsApp (HsApp (HsApp
1356 (HsVar showsPrec_RDR)
1359 (HsLit (HsString (_PK_ ")")))))))
1361 parenify e@(HsVar _) = e
1362 parenify e = HsPar e
1364 -- genOpApp wraps brackets round the operator application, so that the
1365 -- renamer won't subsequently try to re-associate it.
1366 -- For some reason the renamer doesn't reassociate it right, and I can't
1367 -- be bothered to find out why just now.
1369 genOpApp e1 op e2 = mkOpApp e1 op e2
1373 qual_orig_name n = nameRdrName (getName n)
1374 varUnqual n = mkSrcUnqual varName n
1376 zz_a_RDR = varUnqual SLIT("_a")
1377 a_RDR = varUnqual SLIT("a")
1378 b_RDR = varUnqual SLIT("b")
1379 c_RDR = varUnqual SLIT("c")
1380 d_RDR = varUnqual SLIT("d")
1381 ah_RDR = varUnqual SLIT("a#")
1382 bh_RDR = varUnqual SLIT("b#")
1383 ch_RDR = varUnqual SLIT("c#")
1384 dh_RDR = varUnqual SLIT("d#")
1385 cmp_eq_RDR = varUnqual SLIT("cmp_eq")
1386 rangeSize_RDR = varUnqual SLIT("rangeSize")
1388 as_RDRs = [ varUnqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
1389 bs_RDRs = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
1390 cs_RDRs = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
1392 mkHsString s = HsString (_PK_ s)
1394 zz_a_Expr = HsVar zz_a_RDR
1395 a_Expr = HsVar a_RDR
1396 b_Expr = HsVar b_RDR
1397 c_Expr = HsVar c_RDR
1398 d_Expr = HsVar d_RDR
1399 ltTag_Expr = HsVar ltTag_RDR
1400 eqTag_Expr = HsVar eqTag_RDR
1401 gtTag_Expr = HsVar gtTag_RDR
1402 false_Expr = HsVar false_RDR
1403 true_Expr = HsVar true_RDR
1405 getTag_Expr = HsVar getTag_RDR
1406 tagToEnum_Expr = HsVar tagToEnumH_RDR
1407 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1410 zz_a_Pat = VarPatIn zz_a_RDR
1411 a_Pat = VarPatIn a_RDR
1412 b_Pat = VarPatIn b_RDR
1413 c_Pat = VarPatIn c_RDR
1414 d_Pat = VarPatIn d_RDR
1416 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1418 con2tag_RDR tycon = varUnqual (_PK_ ("con2tag_" ++ occNameString (getOccName tycon) ++ "#"))
1419 tag2con_RDR tycon = varUnqual (_PK_ ("tag2con_" ++ occNameString (getOccName tycon) ++ "#"))
1420 maxtag_RDR tycon = varUnqual (_PK_ ("maxtag_" ++ occNameString (getOccName tycon) ++ "#"))