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 ( mkOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
35 import RdrName ( RdrName, mkSrcUnqual )
36 import RnMonad ( FixityEnv, lookupFixity )
37 import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..)
38 , maxPrecedence, defaultFixity
41 import FieldLabel ( fieldLabelName )
42 import DataCon ( isNullaryDataCon, dataConTag,
43 dataConOrigArgTys, dataConSourceArity, fIRST_TAG,
46 import Name ( getOccString, getOccName, getSrcLoc, occNameString,
47 occNameUserString, nameRdrName, varName,
48 OccName, Name, NamedThing(..), NameSpace,
49 isDataSymOcc, isSymOcc
52 import PrimOp ( PrimOp(..) )
53 import PrelInfo -- Lots of RdrNames
54 import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
55 import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
56 maybeTyConSingleCon, tyConFamilySize
58 import Type ( isUnLiftedType, isUnboxedType, Type )
59 import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
60 floatPrimTy, doublePrimTy
62 import Util ( mapAccumL, zipEqual, zipWithEqual,
63 zipWith3Equal, nOfThem, assocDefault )
64 import Panic ( panic, assertPanic )
65 import Maybes ( maybeToBool )
67 import List ( partition, intersperse )
68 import Char ( isAlpha )
70 #if __GLASGOW_HASKELL__ >= 404
71 import GlaExts ( fromInt )
75 %************************************************************************
77 \subsection{Generating code, by derivable class}
79 %************************************************************************
81 %************************************************************************
83 \subsubsection{Generating @Eq@ instance declarations}
85 %************************************************************************
87 Here are the heuristics for the code we generate for @Eq@:
90 Let's assume we have a data type with some (possibly zero) nullary
91 data constructors and some ordinary, non-nullary ones (the rest,
92 also possibly zero of them). Here's an example, with both \tr{N}ullary
93 and \tr{O}rdinary data cons.
95 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
99 For the ordinary constructors (if any), we emit clauses to do The
103 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
104 (==) (O2 a1) (O2 a2) = a1 == a2
105 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
108 Note: if we're comparing unboxed things, e.g., if \tr{a1} and
109 \tr{a2} are \tr{Float#}s, then we have to generate
111 case (a1 `eqFloat#` a2) of
114 for that particular test.
117 If there are any nullary constructors, we emit a catch-all clause of
121 (==) a b = case (con2tag_Foo a) of { a# ->
122 case (con2tag_Foo b) of { b# ->
123 case (a# ==# b#) of {
128 If there aren't any nullary constructors, we emit a simpler
135 For the @(/=)@ method, we normally just use the default method.
137 If the type is an enumeration type, we could/may/should? generate
138 special code that calls @con2tag_Foo@, much like for @(==)@ shown
142 We thought about doing this: If we're also deriving @Ord@ for this
145 instance ... Eq (Foo ...) where
146 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
147 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
149 However, that requires that \tr{Ord <whatever>} was put in the context
150 for the instance decl, which it probably wasn't, so the decls
151 produced don't get through the typechecker.
155 deriveEq :: RdrName -- Class
156 -> RdrName -- Type constructor
157 -> [ (RdrName, [RdrType]) ] -- Constructors
158 -> (RdrContext, -- Context for the inst decl
159 [RdrBind], -- Binds in the inst decl
160 [RdrBind]) -- Extra value bindings outside
162 deriveEq clas tycon constrs
163 = (context, [eq_bind, ne_bind], [])
165 context = [(clas, [ty]) | (_, tys) <- constrs, ty <- tys]
168 (nullary_cons, non_nullary_cons) = partition is_nullary constrs
169 is_nullary (_, args) = null args
172 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
176 tycon_loc = getSrcLoc tycon
177 (nullary_cons, nonnullary_cons)
178 | isNewTyCon tycon = ([], tyConDataCons tycon)
179 | otherwise = partition isNullaryDataCon (tyConDataCons tycon)
182 = if (null nullary_cons) then
183 case maybeTyConSingleCon tycon of
185 Nothing -> -- if cons don't match, then False
186 [([wildPat, wildPat], false_Expr)]
187 else -- calc. and compare the tags
189 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
190 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR true_Expr false_Expr))]
192 mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
194 mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
195 HsApp (HsVar not_RDR) (HsPar (mk_easy_App eq_RDR [a_RDR, b_RDR])))
197 ------------------------------------------------------------------
200 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
201 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
203 data_con_RDR = qual_orig_name data_con
204 con_arity = length tys_needed
205 as_needed = take con_arity as_RDRs
206 bs_needed = take con_arity bs_RDRs
207 tys_needed = dataConOrigArgTys data_con
209 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
211 nested_eq_expr [] [] [] = true_Expr
212 nested_eq_expr tys as bs
213 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
215 nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
218 %************************************************************************
220 \subsubsection{Generating @Ord@ instance declarations}
222 %************************************************************************
224 For a derived @Ord@, we concentrate our attentions on @compare@
226 compare :: a -> a -> Ordering
227 data Ordering = LT | EQ | GT deriving ()
230 We will use the same example data type as above:
232 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
237 We do all the other @Ord@ methods with calls to @compare@:
239 instance ... (Ord <wurble> <wurble>) where
240 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
241 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
242 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
243 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
245 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
246 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
248 -- compare to come...
252 @compare@ always has two parts. First, we use the compared
253 data-constructors' tags to deal with the case of different
256 compare a b = case (con2tag_Foo a) of { a# ->
257 case (con2tag_Foo b) of { b# ->
258 case (a# ==# b#) of {
260 False -> case (a# <# b#) of
265 cmp_eq = ... to come ...
269 We are only left with the ``help'' function @cmp_eq@, to deal with
270 comparing data constructors with the same tag.
272 For the ordinary constructors (if any), we emit the sorta-obvious
273 compare-style stuff; for our example:
275 cmp_eq (O1 a1 b1) (O1 a2 b2)
276 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
278 cmp_eq (O2 a1) (O2 a2)
281 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
282 = case (compare a1 a2) of {
285 EQ -> case compare b1 b2 of {
293 Again, we must be careful about unboxed comparisons. For example,
294 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
298 cmp_eq lt eq gt (O2 a1) (O2 a2)
300 -- or maybe the unfolded equivalent
304 For the remaining nullary constructors, we already know that the
311 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
315 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
318 = compare -- `AndMonoBinds` compare
319 -- The default declaration in PrelBase handles this
321 tycon_loc = getSrcLoc tycon
322 --------------------------------------------------------------------
323 compare = mk_easy_FunMonoBind tycon_loc compare_RDR
326 (if maybeToBool (maybeTyConSingleCon tycon) then
328 -- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
329 -- Wierd. Was: case (cmp a b) of { LT -> LT; EQ -> EQ; GT -> GT }
331 cmp_eq_Expr a_Expr b_Expr
333 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
334 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR
335 -- True case; they are equal
336 -- If an enumeration type we are done; else
337 -- recursively compare their components
338 (if isEnumerationTyCon tycon then
341 -- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
343 cmp_eq_Expr a_Expr b_Expr
345 -- False case; they aren't equal
346 -- So we need to do a less-than comparison on the tags
347 (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
349 tycon_data_cons = tyConDataCons tycon
350 (nullary_cons, nonnullary_cons)
351 | isNewTyCon tycon = ([], tyConDataCons tycon)
352 | otherwise = partition isNullaryDataCon tycon_data_cons
355 mk_FunMonoBind tycon_loc
357 (if null nonnullary_cons && (length nullary_cons == 1) then
358 -- catch this specially to avoid warnings
359 -- about overlapping patterns from the desugarer.
361 data_con = head nullary_cons
362 data_con_RDR = qual_orig_name data_con
363 pat = ConPatIn data_con_RDR []
365 [([pat,pat], eqTag_Expr)]
367 map pats_etc nonnullary_cons ++
368 -- leave out wildcards to silence desugarer.
369 (if length tycon_data_cons == 1 then
372 [([WildPatIn, WildPatIn], default_rhs)]))
375 = ([con1_pat, con2_pat],
376 nested_compare_expr tys_needed as_needed bs_needed)
378 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
379 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
381 data_con_RDR = qual_orig_name data_con
382 con_arity = length tys_needed
383 as_needed = take con_arity as_RDRs
384 bs_needed = take con_arity bs_RDRs
385 tys_needed = dataConOrigArgTys data_con
387 nested_compare_expr [ty] [a] [b]
388 = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
390 nested_compare_expr (ty:tys) (a:as) (b:bs)
391 = let eq_expr = nested_compare_expr tys as bs
392 in careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
394 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
395 -- inexhaustive patterns
396 | otherwise = eqTag_Expr -- Some nullary constructors;
397 -- Tags are equal, no args => return EQ
398 --------------------------------------------------------------------
400 {- Not necessary: the default decls in PrelBase handle these
402 defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
404 lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] (
405 compare_Case true_Expr false_Expr false_Expr a_Expr b_Expr)
406 le = mk_easy_FunMonoBind mkGeneratedSrcLoc le_RDR [a_Pat, b_Pat] [] (
407 compare_Case true_Expr true_Expr false_Expr a_Expr b_Expr)
408 ge = mk_easy_FunMonoBind mkGeneratedSrcLoc ge_RDR [a_Pat, b_Pat] [] (
409 compare_Case false_Expr true_Expr true_Expr a_Expr b_Expr)
410 gt = mk_easy_FunMonoBind mkGeneratedSrcLoc gt_RDR [a_Pat, b_Pat] [] (
411 compare_Case false_Expr false_Expr true_Expr a_Expr b_Expr)
413 max_ = mk_easy_FunMonoBind mkGeneratedSrcLoc max_RDR [a_Pat, b_Pat] [] (
414 compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
415 min_ = mk_easy_FunMonoBind mkGeneratedSrcLoc min_RDR [a_Pat, b_Pat] [] (
416 compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
420 %************************************************************************
422 \subsubsection{Generating @Enum@ instance declarations}
424 %************************************************************************
426 @Enum@ can only be derived for enumeration types. For a type
428 data Foo ... = N1 | N2 | ... | Nn
431 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
432 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
435 instance ... Enum (Foo ...) where
436 succ x = toEnum (1 + fromEnum x)
437 pred x = toEnum (fromEnum x - 1)
439 toEnum i = tag2con_Foo i
441 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
445 = case con2tag_Foo a of
446 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
449 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
453 = case con2tag_Foo a of { a# ->
454 case con2tag_Foo b of { b# ->
455 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
459 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
462 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
465 = succ_enum `AndMonoBinds`
466 pred_enum `AndMonoBinds`
467 to_enum `AndMonoBinds`
468 enum_from `AndMonoBinds`
469 enum_from_then `AndMonoBinds`
472 tycon_loc = getSrcLoc tycon
473 occ_nm = getOccString tycon
476 = mk_easy_FunMonoBind tycon_loc succ_RDR [a_Pat] [] $
477 untag_Expr tycon [(a_RDR, ah_RDR)] $
478 HsIf (HsApp (HsApp (HsVar eq_RDR)
479 (HsVar (maxtag_RDR tycon)))
480 (mk_easy_App mkInt_RDR [ah_RDR]))
481 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
482 (HsApp (HsVar (tag2con_RDR tycon))
483 (HsApp (HsApp (HsVar plus_RDR)
484 (mk_easy_App mkInt_RDR [ah_RDR]))
489 = mk_easy_FunMonoBind tycon_loc pred_RDR [a_Pat] [] $
490 untag_Expr tycon [(a_RDR, ah_RDR)] $
491 HsIf (HsApp (HsApp (HsVar eq_RDR) (HsLit (HsInt 0)))
492 (mk_easy_App mkInt_RDR [ah_RDR]))
493 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
494 (HsApp (HsVar (tag2con_RDR tycon))
495 (HsApp (HsApp (HsVar plus_RDR)
496 (mk_easy_App mkInt_RDR [ah_RDR]))
497 (HsLit (HsInt (-1)))))
501 = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
504 (HsApp (HsApp (HsVar ge_RDR)
507 (HsApp (HsApp (HsVar le_RDR)
509 (HsVar (maxtag_RDR tycon))))
510 (mk_easy_App (tag2con_RDR tycon) [a_RDR])
511 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
515 = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
516 untag_Expr tycon [(a_RDR, ah_RDR)] $
517 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
518 HsPar (enum_from_to_Expr
519 (mk_easy_App mkInt_RDR [ah_RDR])
520 (HsVar (maxtag_RDR tycon)))
523 = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
524 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
525 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
526 HsPar (enum_from_then_to_Expr
527 (mk_easy_App mkInt_RDR [ah_RDR])
528 (mk_easy_App mkInt_RDR [bh_RDR])
529 (HsIf (HsApp (HsApp (HsVar gt_RDR)
530 (mk_easy_App mkInt_RDR [ah_RDR]))
531 (mk_easy_App mkInt_RDR [bh_RDR]))
533 (HsVar (maxtag_RDR tycon))
537 = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
538 untag_Expr tycon [(a_RDR, ah_RDR)] $
539 (mk_easy_App mkInt_RDR [ah_RDR])
542 %************************************************************************
544 \subsubsection{Generating @Bounded@ instance declarations}
546 %************************************************************************
549 gen_Bounded_binds tycon
550 = if isEnumerationTyCon tycon then
551 min_bound_enum `AndMonoBinds` max_bound_enum
553 ASSERT(length data_cons == 1)
554 min_bound_1con `AndMonoBinds` max_bound_1con
556 data_cons = tyConDataCons tycon
557 tycon_loc = getSrcLoc tycon
559 ----- enum-flavored: ---------------------------
560 min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
561 max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR)
563 data_con_1 = head data_cons
564 data_con_N = last data_cons
565 data_con_1_RDR = qual_orig_name data_con_1
566 data_con_N_RDR = qual_orig_name data_con_N
568 ----- single-constructor-flavored: -------------
569 arity = dataConSourceArity data_con_1
571 min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
572 mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
573 max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
574 mk_easy_App data_con_1_RDR (nOfThem arity maxBound_RDR)
577 %************************************************************************
579 \subsubsection{Generating @Ix@ instance declarations}
581 %************************************************************************
583 Deriving @Ix@ is only possible for enumeration types and
584 single-constructor types. We deal with them in turn.
586 For an enumeration type, e.g.,
588 data Foo ... = N1 | N2 | ... | Nn
590 things go not too differently from @Enum@:
592 instance ... Ix (Foo ...) where
594 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
598 = case (con2tag_Foo a) of { a# ->
599 case (con2tag_Foo b) of { b# ->
600 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
605 then case (con2tag_Foo d -# con2tag_Foo a) of
607 else error "Ix.Foo.index: out of range"
611 p_tag = con2tag_Foo c
613 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
617 = case (con2tag_Foo a) of { a_tag ->
618 case (con2tag_Foo b) of { b_tag ->
619 case (con2tag_Foo c) of { c_tag ->
620 if (c_tag >=# a_tag) then
626 (modulo suitable case-ification to handle the unboxed tags)
628 For a single-constructor type (NB: this includes all tuples), e.g.,
630 data Foo ... = MkFoo a b Int Double c c
632 we follow the scheme given in Figure~19 of the Haskell~1.2 report
636 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
639 = if isEnumerationTyCon tycon
643 tycon_str = getOccString tycon
644 tycon_loc = getSrcLoc tycon
646 --------------------------------------------------------------
647 enum_ixes = enum_range `AndMonoBinds`
648 enum_index `AndMonoBinds` enum_inRange
651 = mk_easy_FunMonoBind tycon_loc range_RDR
652 [TuplePatIn [a_Pat, b_Pat] Boxed] [] $
653 untag_Expr tycon [(a_RDR, ah_RDR)] $
654 untag_Expr tycon [(b_RDR, bh_RDR)] $
655 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
656 HsPar (enum_from_to_Expr
657 (mk_easy_App mkInt_RDR [ah_RDR])
658 (mk_easy_App mkInt_RDR [bh_RDR]))
661 = mk_easy_FunMonoBind tycon_loc index_RDR
662 [AsPatIn c_RDR (TuplePatIn [a_Pat, wildPat] Boxed),
664 HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
665 untag_Expr tycon [(a_RDR, ah_RDR)] (
666 untag_Expr tycon [(d_RDR, dh_RDR)] (
668 rhs = mk_easy_App mkInt_RDR [c_RDR]
671 (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
672 [mkSimpleMatch [VarPatIn c_RDR] rhs Nothing tycon_loc]
676 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
681 = mk_easy_FunMonoBind tycon_loc inRange_RDR
682 [TuplePatIn [a_Pat, b_Pat] Boxed, c_Pat] [] (
683 untag_Expr tycon [(a_RDR, ah_RDR)] (
684 untag_Expr tycon [(b_RDR, bh_RDR)] (
685 untag_Expr tycon [(c_RDR, ch_RDR)] (
686 HsIf (genOpApp (HsVar ch_RDR) geH_RDR (HsVar ah_RDR)) (
687 (genOpApp (HsVar ch_RDR) leH_RDR (HsVar bh_RDR))
692 --------------------------------------------------------------
694 = single_con_range `AndMonoBinds`
695 single_con_index `AndMonoBinds`
699 = case maybeTyConSingleCon tycon of -- just checking...
700 Nothing -> panic "get_Ix_binds"
701 Just dc -> if (any isUnLiftedType (dataConOrigArgTys dc)) then
702 error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
706 con_arity = dataConSourceArity data_con
707 data_con_RDR = qual_orig_name data_con
709 as_needed = take con_arity as_RDRs
710 bs_needed = take con_arity bs_RDRs
711 cs_needed = take con_arity cs_RDRs
713 con_pat xs = ConPatIn data_con_RDR (map VarPatIn xs)
714 con_expr = mk_easy_App data_con_RDR cs_needed
716 --------------------------------------------------------------
718 = mk_easy_FunMonoBind tycon_loc range_RDR
719 [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed] [] $
720 HsDo ListComp stmts tycon_loc
722 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
724 [ReturnStmt con_expr]
726 mk_qual a b c = BindStmt (VarPatIn c)
727 (HsApp (HsVar range_RDR)
728 (ExplicitTuple [HsVar a, HsVar b] Boxed))
733 = mk_easy_FunMonoBind tycon_loc index_RDR
734 [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed,
735 con_pat cs_needed] [range_size] (
736 foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
738 mk_index multiply_by (l, u, i)
740 (HsApp (HsApp (HsVar index_RDR)
741 (ExplicitTuple [HsVar l, HsVar u] Boxed)) (HsVar i))
744 (HsApp (HsVar rangeSize_RDR)
745 (ExplicitTuple [HsVar l, HsVar u] Boxed))
746 ) times_RDR multiply_by
750 = mk_easy_FunMonoBind tycon_loc rangeSize_RDR
751 [TuplePatIn [a_Pat, b_Pat] Boxed] [] (
753 (HsApp (HsApp (HsVar index_RDR)
754 (ExplicitTuple [a_Expr, b_Expr] Boxed)) b_Expr)
755 ) plus_RDR (HsLit (HsInt 1)))
759 = mk_easy_FunMonoBind tycon_loc inRange_RDR
760 [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed,
763 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
765 in_range a b c = HsApp (HsApp (HsVar inRange_RDR)
766 (ExplicitTuple [HsVar a, HsVar b] Boxed))
770 %************************************************************************
772 \subsubsection{Generating @Read@ instance declarations}
774 %************************************************************************
777 gen_Read_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
779 gen_Read_binds fixity_env tycon
780 = reads_prec `AndMonoBinds` read_list
782 tycon_loc = getSrcLoc tycon
783 -----------------------------------------------------------------------
784 read_list = mk_easy_FunMonoBind tycon_loc readList_RDR [] []
785 (HsApp (HsVar readList___RDR) (HsPar (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 0)))))
786 -----------------------------------------------------------------------
789 read_con_comprehensions
790 = map read_con (tyConDataCons tycon)
792 mk_easy_FunMonoBind tycon_loc readsPrec_RDR [zz_a_Pat, b_Pat] [] (
793 foldr1 append_Expr read_con_comprehensions
796 read_con data_con -- note: "b" is the string being "read"
798 readParen_Expr read_paren_arg $ HsPar $
799 HsLam (mk_easy_Match tycon_loc [c_Pat] [] $
800 HsDo ListComp stmts tycon_loc)
803 data_con_RDR = qual_orig_name data_con
804 data_con_str = occNameUserString (getOccName data_con)
805 con_arity = dataConSourceArity data_con
806 con_expr = mk_easy_App data_con_RDR as_needed
807 nullary_con = con_arity == 0
808 labels = dataConFieldLabels data_con
809 lab_fields = length labels
810 dc_nm = getName data_con
811 is_infix = isDataSymOcc (getOccName dc_nm)
813 as_needed = take con_arity as_RDRs
815 | is_infix = take (1 + con_arity) bs_RDRs
816 | lab_fields == 0 = take con_arity bs_RDRs
817 | otherwise = take (4*lab_fields + 1) bs_RDRs
818 -- (label, '=' and field)*n, (n-1)*',' + '{' + '}'
820 (as1:as2:_) = as_needed
821 (bs1:bs2:bs3:_) = bs_needed
826 (TuplePatIn [LitPatIn (mkHsString data_con_str), d_Pat] Boxed)
827 (HsApp (HsVar lex_RDR) c_Expr)
831 (TuplePatIn [LitPatIn (mkHsString data_con_str), VarPatIn bs2] Boxed)
832 (HsApp (HsVar lex_RDR) (HsVar bs1))
836 str_qual str res draw_from =
838 (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed)
839 (HsApp (HsVar lex_RDR) draw_from)
842 str_qual_paren str res draw_from =
844 (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed)
845 (HsApp (readParen_Expr true_Expr (HsVar lex_RDR)) draw_from)
848 read_label f = [rd_lab, str_qual "="]
849 -- There might be spaces between the label and '='
852 | is_op = str_qual_paren nm
853 | otherwise = str_qual nm
855 occ_nm = getOccName (fieldLabelName f)
856 is_op = isSymOcc occ_nm
857 nm = occNameUserString occ_nm
861 snd (mapAccumL mk_qual_infix
863 [ (mk_read_qual lp as1, bs1, bs2)
864 , (mk_read_qual rp as2, bs3, bs3)
866 | lab_fields == 0 = -- common case.
867 snd (mapAccumL mk_qual
869 (zipWithEqual "as_needed"
870 (\ con_field draw_from -> (mk_read_qual 10 con_field,
872 as_needed bs_needed))
875 mapAccumL mk_qual d_Expr
876 (zipEqual "bs_needed"
879 intersperse [str_qual ","] $
882 (\ as b -> as ++ [b])
884 (map read_label labels)
886 (map (mk_read_qual 10) as_needed))) ++ [str_qual "}"])
889 mk_qual_infix draw_from (f, str_left, str_left2) =
890 (HsVar str_left2, -- what to draw from down the line...
891 f str_left draw_from)
893 mk_qual draw_from (f, str_left) =
894 (HsVar str_left, -- what to draw from down the line...
895 f str_left draw_from)
897 mk_read_qual p con_field res draw_from =
899 (TuplePatIn [VarPatIn con_field, VarPatIn res] Boxed)
900 (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt p))) draw_from)
903 result_expr = ExplicitTuple [con_expr, if null bs_needed
905 else HsVar (last bs_needed)] Boxed
907 [lp,rp] = getLRPrecs is_infix fixity_env dc_nm
910 | is_infix = let (h:t) = field_quals in (h:con_qual:t)
911 | otherwise = con_qual:field_quals
913 stmts = quals ++ [ReturnStmt result_expr]
916 c.f. Figure 18 in Haskell 1.1 report.
919 | not is_infix = fromInt maxPrecedence
920 | otherwise = getFixity fixity_env dc_nm
922 read_paren_arg -- parens depend on precedence...
923 | nullary_con = false_Expr -- it's optional.
924 | otherwise = HsPar (genOpApp zz_a_Expr gt_RDR (HsLit (HsInt paren_prec_limit)))
927 %************************************************************************
929 \subsubsection{Generating @Show@ instance declarations}
931 %************************************************************************
934 gen_Show_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
936 gen_Show_binds fixity_env tycon
937 = shows_prec `AndMonoBinds` show_list
939 tycon_loc = getSrcLoc tycon
940 -----------------------------------------------------------------------
941 show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
942 (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 0)))))
943 -----------------------------------------------------------------------
944 shows_prec = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
947 | nullary_con = -- skip the showParen junk...
948 ASSERT(null bs_needed)
949 ([wildPat, con_pat], show_con)
952 showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt paren_prec_limit))))
953 (HsPar (nested_compose_Expr show_thingies)))
955 data_con_RDR = qual_orig_name data_con
956 con_arity = dataConSourceArity data_con
957 bs_needed = take con_arity bs_RDRs
958 con_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
959 nullary_con = con_arity == 0
960 labels = dataConFieldLabels data_con
961 lab_fields = length labels
963 dc_nm = getName data_con
964 dc_occ_nm = getOccName data_con
965 dc_occ_nm_str = occNameUserString dc_occ_nm
967 is_infix = isDataSymOcc dc_occ_nm
971 | is_infix = mk_showString_app (' ':dc_occ_nm_str)
972 | otherwise = mk_showString_app (dc_occ_nm_str ++ space_ocurly_maybe)
976 | lab_fields == 0 = " "
980 show_all con fs@(x:xs)
981 | is_infix = x:con:xs
985 | lab_fields > 0 = [mk_showString_app "}"]
988 con:fs ++ ccurly_maybe
990 show_thingies = show_all show_con real_show_thingies_with_labs
992 show_label l = mk_showString_app (the_name ++ "=")
994 occ_nm = getOccName (fieldLabelName l)
996 is_op = isSymOcc occ_nm
998 | is_op = '(':nm ++ ")"
1001 nm = occNameUserString occ_nm
1004 mk_showString_app str = HsApp (HsVar showString_RDR)
1005 (HsLit (mkHsString str))
1007 prec_cons = getLRPrecs is_infix fixity_env dc_nm
1011 [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt p))) (HsVar b)
1012 | (p,b) <- zip prec_cons bs_needed ]
1014 [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
1017 real_show_thingies_with_labs
1018 | lab_fields == 0 = intersperse (HsVar showSpace_RDR) real_show_thingies
1019 | otherwise = --Assumption: no of fields == no of labelled fields
1020 -- (and in same order)
1022 intersperse ([mk_showString_app ","]) $ -- Using SLIT()s containing ,s spells trouble.
1023 zipWithEqual "gen_Show_binds"
1025 (map show_label labels)
1028 (con_left_assoc, con_right_assoc) = isLRAssoc fixity_env dc_nm
1031 c.f. Figure 16 and 17 in Haskell 1.1 report
1034 | not is_infix = fromInt maxPrecedence + 1
1035 | otherwise = getFixity fixity_env dc_nm + 1
1040 getLRPrecs :: Bool -> FixityEnv -> Name -> [Integer]
1041 getLRPrecs is_infix fixity_env nm = [lp, rp]
1044 Figuring out the fixities of the arguments to a constructor,
1045 cf. Figures 16-18 in Haskell 1.1 report.
1047 (con_left_assoc, con_right_assoc) = isLRAssoc fixity_env nm
1048 paren_con_prec = getFixity fixity_env nm
1049 maxPrec = fromInt maxPrecedence
1052 | not is_infix = maxPrec + 1
1053 | con_left_assoc = paren_con_prec
1054 | otherwise = paren_con_prec + 1
1057 | not is_infix = maxPrec + 1
1058 | con_right_assoc = paren_con_prec
1059 | otherwise = paren_con_prec + 1
1061 getFixity :: FixityEnv -> Name -> Integer
1062 getFixity fixity_env nm = case lookupFixity fixity_env nm of
1063 Fixity x _ -> fromInt x
1065 isLRAssoc :: FixityEnv -> 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 isInfixOccName :: String -> Bool
1073 isInfixOccName str =
1080 %************************************************************************
1082 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1084 %************************************************************************
1089 con2tag_Foo :: Foo ... -> Int#
1090 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1091 maxtag_Foo :: Int -- ditto (NB: not unboxed)
1094 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1099 = GenCon2Tag | GenTag2Con | GenMaxTag
1101 gen_tag_n_con_monobind
1102 :: (RdrName, -- (proto)Name for the thing in question
1103 TyCon, -- tycon in question
1107 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1108 | lots_of_constructors
1109 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1110 [([VarPatIn a_RDR], HsApp getTag_Expr a_Expr)]
1113 = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
1116 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1118 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
1120 = ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
1122 pat = ConPatIn var_RDR (nOfThem (dataConSourceArity var) WildPatIn)
1123 var_RDR = qual_orig_name var
1125 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1126 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1127 [([ConPatIn mkInt_RDR [VarPatIn a_RDR]],
1128 ExprWithTySig (HsApp tagToEnum_Expr a_Expr)
1129 (HsTyVar (qual_orig_name tycon)))]
1131 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1132 = mk_easy_FunMonoBind (getSrcLoc tycon)
1133 rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
1135 max_tag = case (tyConDataCons tycon) of
1136 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1140 %************************************************************************
1142 \subsection{Utility bits for generating bindings}
1144 %************************************************************************
1146 @mk_easy_FunMonoBind fun pats binds expr@ generates:
1148 fun pat1 pat2 ... patN = expr where binds
1151 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
1152 multi-clause definitions; it generates:
1154 fun p1a p1b ... p1N = e1
1155 fun p2a p2b ... p2N = e2
1157 fun pMa pMb ... pMN = eM
1161 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
1162 -> [RdrNameMonoBinds] -> RdrNameHsExpr
1165 mk_easy_FunMonoBind loc fun pats binds expr
1166 = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
1168 mk_easy_Match loc pats binds expr
1169 = mk_match loc pats expr (mkMonoBind (andMonoBindList binds) [] Recursive)
1170 -- The renamer expects everything in its input to be a
1171 -- "recursive" MonoBinds, and it is its job to sort things out
1174 mk_FunMonoBind :: SrcLoc -> RdrName
1175 -> [([RdrNamePat], RdrNameHsExpr)]
1178 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
1179 mk_FunMonoBind loc fun pats_and_exprs
1180 = FunMonoBind fun False{-not infix-}
1181 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
1184 mk_match loc pats expr binds
1185 = Match [] (map paren pats) Nothing
1186 (GRHSs (unguardedRHS expr loc) binds Nothing)
1188 paren p@(VarPatIn _) = p
1189 paren other_p = ParPatIn other_p
1193 mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
1196 ToDo: Better SrcLocs.
1200 RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1201 -> RdrNameHsExpr -> RdrNameHsExpr
1205 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1206 -> RdrNameHsExpr -> RdrNameHsExpr
1208 careful_compare_Case :: -- checks for primitive types...
1210 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1211 -> RdrNameHsExpr -> RdrNameHsExpr
1214 compare_Case = compare_gen_Case compare_RDR
1215 cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b
1216 -- Was: compare_gen_Case cmp_eq_RDR
1218 compare_gen_Case fun lt eq gt a b
1219 = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
1220 [mkSimpleMatch [ConPatIn ltTag_RDR []] lt Nothing mkGeneratedSrcLoc,
1221 mkSimpleMatch [ConPatIn eqTag_RDR []] eq Nothing mkGeneratedSrcLoc,
1222 mkSimpleMatch [ConPatIn gtTag_RDR []] gt Nothing mkGeneratedSrcLoc]
1225 careful_compare_Case ty lt eq gt a b
1226 = if not (isUnboxedType ty) then
1227 compare_gen_Case compare_RDR lt eq gt a b
1229 else -- we have to do something special for primitive things...
1230 HsIf (genOpApp a relevant_eq_op b)
1232 (HsIf (genOpApp a relevant_lt_op b) lt gt mkGeneratedSrcLoc)
1235 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1236 relevant_lt_op = assoc_ty_id lt_op_tbl ty
1238 assoc_ty_id tyids ty
1239 = if null res then panic "assoc_ty"
1242 res = [id | (ty',id) <- tyids, ty == ty']
1245 [(charPrimTy, eqH_Char_RDR)
1246 ,(intPrimTy, eqH_Int_RDR)
1247 ,(wordPrimTy, eqH_Word_RDR)
1248 ,(addrPrimTy, eqH_Addr_RDR)
1249 ,(floatPrimTy, eqH_Float_RDR)
1250 ,(doublePrimTy, eqH_Double_RDR)
1254 [(charPrimTy, ltH_Char_RDR)
1255 ,(intPrimTy, ltH_Int_RDR)
1256 ,(wordPrimTy, ltH_Word_RDR)
1257 ,(addrPrimTy, ltH_Addr_RDR)
1258 ,(floatPrimTy, ltH_Float_RDR)
1259 ,(doublePrimTy, ltH_Double_RDR)
1262 -----------------------------------------------------------------------
1264 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1266 and_Expr a b = genOpApp a and_RDR b
1267 append_Expr a b = genOpApp a append_RDR b
1269 -----------------------------------------------------------------------
1271 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1273 = if not (isUnboxedType ty) then
1275 else -- we have to do something special for primitive things...
1276 genOpApp a relevant_eq_op b
1278 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1282 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
1283 untag_Expr tycon [] expr = expr
1284 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1285 = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1286 [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) Nothing mkGeneratedSrcLoc]
1289 cmp_tags_Expr :: RdrName -- Comparison op
1290 -> RdrName -> RdrName -- Things to compare
1291 -> RdrNameHsExpr -- What to return if true
1292 -> RdrNameHsExpr -- What to return if false
1295 cmp_tags_Expr op a b true_case false_case
1296 = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case mkGeneratedSrcLoc
1299 :: RdrNameHsExpr -> RdrNameHsExpr
1301 enum_from_then_to_Expr
1302 :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1305 enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1306 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1308 showParen_Expr, readParen_Expr
1309 :: RdrNameHsExpr -> RdrNameHsExpr
1312 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1313 readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_RDR) e1) e2
1315 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1317 nested_compose_Expr [e] = parenify e
1318 nested_compose_Expr (e:es)
1319 = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1321 -- impossible_Expr is used in case RHSs that should never happen.
1322 -- We generate these to keep the desugarer from complaining that they *might* happen!
1323 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ "Urk! in TcGenDeriv")))
1325 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1326 -- method. It is currently only used by Enum.{succ,pred}
1327 illegal_Expr meth tp msg =
1328 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ (meth ++ '{':tp ++ "}: " ++ msg))))
1330 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1331 -- to include the value of a_RDR in the error string.
1332 illegal_toEnum_tag tp maxtag =
1333 HsApp (HsVar error_RDR)
1334 (HsApp (HsApp (HsVar append_RDR)
1335 (HsLit (HsString (_PK_ ("toEnum{" ++ tp ++ "}: tag (")))))
1336 (HsApp (HsApp (HsApp
1337 (HsVar showsPrec_RDR)
1342 (HsLit (HsString (_PK_ ") is outside of enumeration's range (0,"))))
1343 (HsApp (HsApp (HsApp
1344 (HsVar showsPrec_RDR)
1347 (HsLit (HsString (_PK_ ")")))))))
1349 parenify e@(HsVar _) = e
1350 parenify e = HsPar e
1352 -- genOpApp wraps brackets round the operator application, so that the
1353 -- renamer won't subsequently try to re-associate it.
1354 -- For some reason the renamer doesn't reassociate it right, and I can't
1355 -- be bothered to find out why just now.
1357 genOpApp e1 op e2 = mkOpApp e1 op e2
1361 qual_orig_name n = nameRdrName (getName n)
1362 varUnqual n = mkSrcUnqual varName n
1364 zz_a_RDR = varUnqual SLIT("_a")
1365 a_RDR = varUnqual SLIT("a")
1366 b_RDR = varUnqual SLIT("b")
1367 c_RDR = varUnqual SLIT("c")
1368 d_RDR = varUnqual SLIT("d")
1369 ah_RDR = varUnqual SLIT("a#")
1370 bh_RDR = varUnqual SLIT("b#")
1371 ch_RDR = varUnqual SLIT("c#")
1372 dh_RDR = varUnqual SLIT("d#")
1373 cmp_eq_RDR = varUnqual SLIT("cmp_eq")
1374 rangeSize_RDR = varUnqual SLIT("rangeSize")
1376 as_RDRs = [ varUnqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
1377 bs_RDRs = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
1378 cs_RDRs = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
1380 mkHsString s = HsString (_PK_ s)
1382 zz_a_Expr = HsVar zz_a_RDR
1383 a_Expr = HsVar a_RDR
1384 b_Expr = HsVar b_RDR
1385 c_Expr = HsVar c_RDR
1386 d_Expr = HsVar d_RDR
1387 ltTag_Expr = HsVar ltTag_RDR
1388 eqTag_Expr = HsVar eqTag_RDR
1389 gtTag_Expr = HsVar gtTag_RDR
1390 false_Expr = HsVar false_RDR
1391 true_Expr = HsVar true_RDR
1393 getTag_Expr = HsVar getTag_RDR
1394 tagToEnum_Expr = HsVar tagToEnumH_RDR
1395 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1398 zz_a_Pat = VarPatIn zz_a_RDR
1399 a_Pat = VarPatIn a_RDR
1400 b_Pat = VarPatIn b_RDR
1401 c_Pat = VarPatIn c_RDR
1402 d_Pat = VarPatIn d_RDR
1404 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1406 con2tag_RDR tycon = varUnqual (_PK_ ("con2tag_" ++ occNameString (getOccName tycon) ++ "#"))
1407 tag2con_RDR tycon = varUnqual (_PK_ ("tag2con_" ++ occNameString (getOccName tycon) ++ "#"))
1408 maxtag_RDR tycon = varUnqual (_PK_ ("maxtag_" ++ occNameString (getOccName tycon) ++ "#"))