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 ( generatedSrcLoc, 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 )
66 import Outputable ( pprPanic, ppr, pprTrace )
68 #if __GLASGOW_HASKELL__ >= 404
69 import GlaExts ( fromInt )
73 %************************************************************************
75 \subsection{Generating code, by derivable class}
77 %************************************************************************
79 %************************************************************************
81 \subsubsection{Generating @Eq@ instance declarations}
83 %************************************************************************
85 Here are the heuristics for the code we generate for @Eq@:
88 Let's assume we have a data type with some (possibly zero) nullary
89 data constructors and some ordinary, non-nullary ones (the rest,
90 also possibly zero of them). Here's an example, with both \tr{N}ullary
91 and \tr{O}rdinary data cons.
93 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
97 For the ordinary constructors (if any), we emit clauses to do The
101 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
102 (==) (O2 a1) (O2 a2) = a1 == a2
103 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
106 Note: if we're comparing unboxed things, e.g., if \tr{a1} and
107 \tr{a2} are \tr{Float#}s, then we have to generate
109 case (a1 `eqFloat#` a2) of
112 for that particular test.
115 If there are any nullary constructors, we emit a catch-all clause of
119 (==) a b = case (con2tag_Foo a) of { a# ->
120 case (con2tag_Foo b) of { b# ->
121 case (a# ==# b#) of {
126 If there aren't any nullary constructors, we emit a simpler
133 For the @(/=)@ method, we normally just use the default method.
135 If the type is an enumeration type, we could/may/should? generate
136 special code that calls @con2tag_Foo@, much like for @(==)@ shown
140 We thought about doing this: If we're also deriving @Ord@ for this
143 instance ... Eq (Foo ...) where
144 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
145 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
147 However, that requires that \tr{Ord <whatever>} was put in the context
148 for the instance decl, which it probably wasn't, so the decls
149 produced don't get through the typechecker.
153 deriveEq :: RdrName -- Class
154 -> RdrName -- Type constructor
155 -> [ (RdrName, [RdrType]) ] -- Constructors
156 -> (RdrContext, -- Context for the inst decl
157 [RdrBind], -- Binds in the inst decl
158 [RdrBind]) -- Extra value bindings outside
160 deriveEq clas tycon constrs
161 = (context, [eq_bind, ne_bind], [])
163 context = [(clas, [ty]) | (_, tys) <- constrs, ty <- tys]
166 (nullary_cons, non_nullary_cons) = partition is_nullary constrs
167 is_nullary (_, args) = null args
170 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
174 tycon_loc = getSrcLoc tycon
175 (nullary_cons, nonnullary_cons)
176 | isNewTyCon tycon = ([], tyConDataCons tycon)
177 | otherwise = partition isNullaryDataCon (tyConDataCons tycon)
180 = if (null nullary_cons) then
181 case maybeTyConSingleCon tycon of
183 Nothing -> -- if cons don't match, then False
184 [([wildPat, wildPat], false_Expr)]
185 else -- calc. and compare the tags
187 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
188 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR true_Expr false_Expr))]
190 mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
192 mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
193 HsApp (HsVar not_RDR) (HsPar (mk_easy_App eq_RDR [a_RDR, b_RDR])))
195 ------------------------------------------------------------------
198 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
199 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
201 data_con_RDR = qual_orig_name data_con
202 con_arity = length tys_needed
203 as_needed = take con_arity as_RDRs
204 bs_needed = take con_arity bs_RDRs
205 tys_needed = dataConOrigArgTys data_con
207 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
209 nested_eq_expr [] [] [] = true_Expr
210 nested_eq_expr tys as bs
211 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
213 nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
216 %************************************************************************
218 \subsubsection{Generating @Ord@ instance declarations}
220 %************************************************************************
222 For a derived @Ord@, we concentrate our attentions on @compare@
224 compare :: a -> a -> Ordering
225 data Ordering = LT | EQ | GT deriving ()
228 We will use the same example data type as above:
230 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
235 We do all the other @Ord@ methods with calls to @compare@:
237 instance ... (Ord <wurble> <wurble>) where
238 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
239 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
240 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
241 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
243 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
244 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
246 -- compare to come...
250 @compare@ always has two parts. First, we use the compared
251 data-constructors' tags to deal with the case of different
254 compare a b = case (con2tag_Foo a) of { a# ->
255 case (con2tag_Foo b) of { b# ->
256 case (a# ==# b#) of {
258 False -> case (a# <# b#) of
263 cmp_eq = ... to come ...
267 We are only left with the ``help'' function @cmp_eq@, to deal with
268 comparing data constructors with the same tag.
270 For the ordinary constructors (if any), we emit the sorta-obvious
271 compare-style stuff; for our example:
273 cmp_eq (O1 a1 b1) (O1 a2 b2)
274 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
276 cmp_eq (O2 a1) (O2 a2)
279 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
280 = case (compare a1 a2) of {
283 EQ -> case compare b1 b2 of {
291 Again, we must be careful about unboxed comparisons. For example,
292 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
296 cmp_eq lt eq gt (O2 a1) (O2 a2)
298 -- or maybe the unfolded equivalent
302 For the remaining nullary constructors, we already know that the
309 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
313 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
316 = compare -- `AndMonoBinds` compare
317 -- The default declaration in PrelBase handles this
319 tycon_loc = getSrcLoc tycon
320 --------------------------------------------------------------------
321 compare = mk_easy_FunMonoBind tycon_loc compare_RDR
324 (if maybeToBool (maybeTyConSingleCon tycon) then
326 -- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
327 -- Wierd. Was: case (cmp a b) of { LT -> LT; EQ -> EQ; GT -> GT }
329 cmp_eq_Expr a_Expr b_Expr
331 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
332 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR
333 -- True case; they are equal
334 -- If an enumeration type we are done; else
335 -- recursively compare their components
336 (if isEnumerationTyCon tycon then
339 -- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
341 cmp_eq_Expr a_Expr b_Expr
343 -- False case; they aren't equal
344 -- So we need to do a less-than comparison on the tags
345 (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
347 tycon_data_cons = tyConDataCons tycon
348 (nullary_cons, nonnullary_cons)
349 | isNewTyCon tycon = ([], tyConDataCons tycon)
350 | otherwise = partition isNullaryDataCon tycon_data_cons
353 mk_FunMonoBind tycon_loc
355 (if null nonnullary_cons && (length nullary_cons == 1) then
356 -- catch this specially to avoid warnings
357 -- about overlapping patterns from the desugarer.
359 data_con = head nullary_cons
360 data_con_RDR = qual_orig_name data_con
361 pat = ConPatIn data_con_RDR []
363 [([pat,pat], eqTag_Expr)]
365 map pats_etc nonnullary_cons ++
366 -- leave out wildcards to silence desugarer.
367 (if length tycon_data_cons == 1 then
370 [([WildPatIn, WildPatIn], default_rhs)]))
373 = ([con1_pat, con2_pat],
374 nested_compare_expr tys_needed as_needed bs_needed)
376 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
377 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
379 data_con_RDR = qual_orig_name data_con
380 con_arity = length tys_needed
381 as_needed = take con_arity as_RDRs
382 bs_needed = take con_arity bs_RDRs
383 tys_needed = dataConOrigArgTys data_con
385 nested_compare_expr [ty] [a] [b]
386 = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
388 nested_compare_expr (ty:tys) (a:as) (b:bs)
389 = let eq_expr = nested_compare_expr tys as bs
390 in careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
392 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
393 -- inexhaustive patterns
394 | otherwise = eqTag_Expr -- Some nullary constructors;
395 -- Tags are equal, no args => return EQ
396 --------------------------------------------------------------------
398 {- Not necessary: the default decls in PrelBase handle these
400 defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
402 lt = mk_easy_FunMonoBind generatedSrcLoc lt_RDR [a_Pat, b_Pat] [] (
403 compare_Case true_Expr false_Expr false_Expr a_Expr b_Expr)
404 le = mk_easy_FunMonoBind generatedSrcLoc le_RDR [a_Pat, b_Pat] [] (
405 compare_Case true_Expr true_Expr false_Expr a_Expr b_Expr)
406 ge = mk_easy_FunMonoBind generatedSrcLoc ge_RDR [a_Pat, b_Pat] [] (
407 compare_Case false_Expr true_Expr true_Expr a_Expr b_Expr)
408 gt = mk_easy_FunMonoBind generatedSrcLoc gt_RDR [a_Pat, b_Pat] [] (
409 compare_Case false_Expr false_Expr true_Expr a_Expr b_Expr)
411 max_ = mk_easy_FunMonoBind generatedSrcLoc max_RDR [a_Pat, b_Pat] [] (
412 compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
413 min_ = mk_easy_FunMonoBind generatedSrcLoc min_RDR [a_Pat, b_Pat] [] (
414 compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
418 %************************************************************************
420 \subsubsection{Generating @Enum@ instance declarations}
422 %************************************************************************
424 @Enum@ can only be derived for enumeration types. For a type
426 data Foo ... = N1 | N2 | ... | Nn
429 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
430 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
433 instance ... Enum (Foo ...) where
434 succ x = toEnum (1 + fromEnum x)
435 pred x = toEnum (fromEnum x - 1)
437 toEnum i = tag2con_Foo i
439 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
443 = case con2tag_Foo a of
444 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
447 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
451 = case con2tag_Foo a of { a# ->
452 case con2tag_Foo b of { b# ->
453 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
457 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
460 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
463 = succ_enum `AndMonoBinds`
464 pred_enum `AndMonoBinds`
465 to_enum `AndMonoBinds`
466 enum_from `AndMonoBinds`
467 enum_from_then `AndMonoBinds`
470 tycon_loc = getSrcLoc tycon
471 occ_nm = getOccString tycon
474 = mk_easy_FunMonoBind tycon_loc succ_RDR [a_Pat] [] $
475 untag_Expr tycon [(a_RDR, ah_RDR)] $
476 HsIf (HsApp (HsApp (HsVar eq_RDR)
477 (HsVar (maxtag_RDR tycon)))
478 (mk_easy_App mkInt_RDR [ah_RDR]))
479 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
480 (HsApp (HsVar (tag2con_RDR tycon))
481 (HsApp (HsApp (HsVar plus_RDR)
482 (mk_easy_App mkInt_RDR [ah_RDR]))
487 = mk_easy_FunMonoBind tycon_loc pred_RDR [a_Pat] [] $
488 untag_Expr tycon [(a_RDR, ah_RDR)] $
489 HsIf (HsApp (HsApp (HsVar eq_RDR) (HsLit (HsInt 0)))
490 (mk_easy_App mkInt_RDR [ah_RDR]))
491 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
492 (HsApp (HsVar (tag2con_RDR tycon))
493 (HsApp (HsApp (HsVar plus_RDR)
494 (mk_easy_App mkInt_RDR [ah_RDR]))
495 (HsLit (HsInt (-1)))))
499 = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
502 (HsApp (HsApp (HsVar ge_RDR)
505 (HsApp (HsApp (HsVar le_RDR)
507 (HsVar (maxtag_RDR tycon))))
508 (mk_easy_App (tag2con_RDR tycon) [a_RDR])
509 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
513 = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
514 untag_Expr tycon [(a_RDR, ah_RDR)] $
515 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
516 HsPar (enum_from_to_Expr
517 (mk_easy_App mkInt_RDR [ah_RDR])
518 (HsVar (maxtag_RDR tycon)))
521 = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
522 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
523 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
524 HsPar (enum_from_then_to_Expr
525 (mk_easy_App mkInt_RDR [ah_RDR])
526 (mk_easy_App mkInt_RDR [bh_RDR])
527 (HsIf (HsApp (HsApp (HsVar gt_RDR)
528 (mk_easy_App mkInt_RDR [ah_RDR]))
529 (mk_easy_App mkInt_RDR [bh_RDR]))
531 (HsVar (maxtag_RDR tycon))
535 = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
536 untag_Expr tycon [(a_RDR, ah_RDR)] $
537 (mk_easy_App mkInt_RDR [ah_RDR])
540 %************************************************************************
542 \subsubsection{Generating @Bounded@ instance declarations}
544 %************************************************************************
547 gen_Bounded_binds tycon
548 = if isEnumerationTyCon tycon then
549 min_bound_enum `AndMonoBinds` max_bound_enum
551 ASSERT(length data_cons == 1)
552 min_bound_1con `AndMonoBinds` max_bound_1con
554 data_cons = tyConDataCons tycon
555 tycon_loc = getSrcLoc tycon
557 ----- enum-flavored: ---------------------------
558 min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
559 max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR)
561 data_con_1 = head data_cons
562 data_con_N = last data_cons
563 data_con_1_RDR = qual_orig_name data_con_1
564 data_con_N_RDR = qual_orig_name data_con_N
566 ----- single-constructor-flavored: -------------
567 arity = dataConSourceArity data_con_1
569 min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
570 mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
571 max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
572 mk_easy_App data_con_1_RDR (nOfThem arity maxBound_RDR)
575 %************************************************************************
577 \subsubsection{Generating @Ix@ instance declarations}
579 %************************************************************************
581 Deriving @Ix@ is only possible for enumeration types and
582 single-constructor types. We deal with them in turn.
584 For an enumeration type, e.g.,
586 data Foo ... = N1 | N2 | ... | Nn
588 things go not too differently from @Enum@:
590 instance ... Ix (Foo ...) where
592 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
596 = case (con2tag_Foo a) of { a# ->
597 case (con2tag_Foo b) of { b# ->
598 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
603 then case (con2tag_Foo d -# con2tag_Foo a) of
605 else error "Ix.Foo.index: out of range"
609 p_tag = con2tag_Foo c
611 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
615 = case (con2tag_Foo a) of { a_tag ->
616 case (con2tag_Foo b) of { b_tag ->
617 case (con2tag_Foo c) of { c_tag ->
618 if (c_tag >=# a_tag) then
624 (modulo suitable case-ification to handle the unboxed tags)
626 For a single-constructor type (NB: this includes all tuples), e.g.,
628 data Foo ... = MkFoo a b Int Double c c
630 we follow the scheme given in Figure~19 of the Haskell~1.2 report
634 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
637 = if isEnumerationTyCon tycon
641 tycon_str = getOccString tycon
642 tycon_loc = getSrcLoc tycon
644 --------------------------------------------------------------
645 enum_ixes = enum_range `AndMonoBinds`
646 enum_index `AndMonoBinds` enum_inRange
649 = mk_easy_FunMonoBind tycon_loc range_RDR
650 [TuplePatIn [a_Pat, b_Pat] Boxed] [] $
651 untag_Expr tycon [(a_RDR, ah_RDR)] $
652 untag_Expr tycon [(b_RDR, bh_RDR)] $
653 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
654 HsPar (enum_from_to_Expr
655 (mk_easy_App mkInt_RDR [ah_RDR])
656 (mk_easy_App mkInt_RDR [bh_RDR]))
659 = mk_easy_FunMonoBind tycon_loc index_RDR
660 [AsPatIn c_RDR (TuplePatIn [a_Pat, wildPat] Boxed),
662 HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
663 untag_Expr tycon [(a_RDR, ah_RDR)] (
664 untag_Expr tycon [(d_RDR, dh_RDR)] (
666 rhs = mk_easy_App mkInt_RDR [c_RDR]
669 (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
670 [mkSimpleMatch [VarPatIn c_RDR] rhs Nothing tycon_loc]
674 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
679 = mk_easy_FunMonoBind tycon_loc inRange_RDR
680 [TuplePatIn [a_Pat, b_Pat] Boxed, c_Pat] [] (
681 untag_Expr tycon [(a_RDR, ah_RDR)] (
682 untag_Expr tycon [(b_RDR, bh_RDR)] (
683 untag_Expr tycon [(c_RDR, ch_RDR)] (
684 HsIf (genOpApp (HsVar ch_RDR) geH_RDR (HsVar ah_RDR)) (
685 (genOpApp (HsVar ch_RDR) leH_RDR (HsVar bh_RDR))
690 --------------------------------------------------------------
692 = single_con_range `AndMonoBinds`
693 single_con_index `AndMonoBinds`
697 = case maybeTyConSingleCon tycon of -- just checking...
698 Nothing -> panic "get_Ix_binds"
699 Just dc -> if (any isUnLiftedType (dataConOrigArgTys dc)) then
700 error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
704 con_arity = dataConSourceArity data_con
705 data_con_RDR = qual_orig_name data_con
707 as_needed = take con_arity as_RDRs
708 bs_needed = take con_arity bs_RDRs
709 cs_needed = take con_arity cs_RDRs
711 con_pat xs = ConPatIn data_con_RDR (map VarPatIn xs)
712 con_expr = mk_easy_App data_con_RDR cs_needed
714 --------------------------------------------------------------
716 = mk_easy_FunMonoBind tycon_loc range_RDR
717 [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed] [] $
718 HsDo ListComp stmts tycon_loc
720 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
722 [ReturnStmt con_expr]
724 mk_qual a b c = BindStmt (VarPatIn c)
725 (HsApp (HsVar range_RDR)
726 (ExplicitTuple [HsVar a, HsVar b] Boxed))
731 = mk_easy_FunMonoBind tycon_loc index_RDR
732 [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed,
733 con_pat cs_needed] [range_size] (
734 foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
736 mk_index multiply_by (l, u, i)
738 (HsApp (HsApp (HsVar index_RDR)
739 (ExplicitTuple [HsVar l, HsVar u] Boxed)) (HsVar i))
742 (HsApp (HsVar rangeSize_RDR)
743 (ExplicitTuple [HsVar l, HsVar u] Boxed))
744 ) times_RDR multiply_by
748 = mk_easy_FunMonoBind tycon_loc rangeSize_RDR
749 [TuplePatIn [a_Pat, b_Pat] Boxed] [] (
751 (HsApp (HsApp (HsVar index_RDR)
752 (ExplicitTuple [a_Expr, b_Expr] Boxed)) b_Expr)
753 ) plus_RDR (HsLit (HsInt 1)))
757 = mk_easy_FunMonoBind tycon_loc inRange_RDR
758 [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed,
761 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
763 in_range a b c = HsApp (HsApp (HsVar inRange_RDR)
764 (ExplicitTuple [HsVar a, HsVar b] Boxed))
768 %************************************************************************
770 \subsubsection{Generating @Read@ instance declarations}
772 %************************************************************************
775 gen_Read_binds :: (Name -> Maybe Fixity) -> TyCon -> RdrNameMonoBinds
777 gen_Read_binds get_fixity tycon
778 = reads_prec `AndMonoBinds` read_list
780 tycon_loc = getSrcLoc tycon
781 -----------------------------------------------------------------------
782 read_list = mk_easy_FunMonoBind tycon_loc readList_RDR [] []
783 (HsApp (HsVar readList___RDR) (HsPar (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 0)))))
784 -----------------------------------------------------------------------
787 read_con_comprehensions
788 = map read_con (tyConDataCons tycon)
790 mk_easy_FunMonoBind tycon_loc readsPrec_RDR [zz_a_Pat, b_Pat] [] (
791 foldr1 append_Expr read_con_comprehensions
794 read_con data_con -- note: "b" is the string being "read"
796 readParen_Expr read_paren_arg $ HsPar $
797 HsLam (mk_easy_Match tycon_loc [c_Pat] [] $
798 HsDo ListComp stmts tycon_loc)
801 data_con_RDR = qual_orig_name data_con
802 data_con_str = occNameUserString (getOccName data_con)
803 con_arity = dataConSourceArity data_con
804 con_expr = mk_easy_App data_con_RDR as_needed
805 nullary_con = con_arity == 0
806 labels = dataConFieldLabels data_con
807 lab_fields = length labels
808 dc_nm = getName data_con
809 is_infix = isDataSymOcc (getOccName dc_nm)
811 as_needed = take con_arity as_RDRs
813 | is_infix = take (1 + con_arity) bs_RDRs
814 | lab_fields == 0 = take con_arity bs_RDRs
815 | otherwise = take (4*lab_fields + 1) bs_RDRs
816 -- (label, '=' and field)*n, (n-1)*',' + '{' + '}'
818 (as1:as2:_) = as_needed
819 (bs1:bs2:bs3:_) = bs_needed
824 (TuplePatIn [LitPatIn (mkHsString data_con_str), d_Pat] Boxed)
825 (HsApp (HsVar lex_RDR) c_Expr)
829 (TuplePatIn [LitPatIn (mkHsString data_con_str), VarPatIn bs2] Boxed)
830 (HsApp (HsVar lex_RDR) (HsVar bs1))
834 str_qual str res draw_from =
836 (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed)
837 (HsApp (HsVar lex_RDR) draw_from)
840 str_qual_paren str res draw_from =
842 (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed)
843 (HsApp (readParen_Expr true_Expr (HsVar lex_RDR)) draw_from)
846 read_label f = [rd_lab, str_qual "="]
847 -- There might be spaces between the label and '='
850 | is_op = str_qual_paren nm
851 | otherwise = str_qual nm
853 occ_nm = getOccName (fieldLabelName f)
854 is_op = isSymOcc occ_nm
855 nm = occNameUserString occ_nm
859 snd (mapAccumL mk_qual_infix
861 [ (mk_read_qual lp as1, bs1, bs2)
862 , (mk_read_qual rp as2, bs3, bs3)
864 | lab_fields == 0 = -- common case.
865 snd (mapAccumL mk_qual
867 (zipWithEqual "as_needed"
868 (\ con_field draw_from -> (mk_read_qual 10 con_field,
870 as_needed bs_needed))
873 mapAccumL mk_qual d_Expr
874 (zipEqual "bs_needed"
877 intersperse [str_qual ","] $
880 (\ as b -> as ++ [b])
882 (map read_label labels)
884 (map (mk_read_qual 10) as_needed))) ++ [str_qual "}"])
887 mk_qual_infix draw_from (f, str_left, str_left2) =
888 (HsVar str_left2, -- what to draw from down the line...
889 f str_left draw_from)
891 mk_qual draw_from (f, str_left) =
892 (HsVar str_left, -- what to draw from down the line...
893 f str_left draw_from)
895 mk_read_qual p con_field res draw_from =
897 (TuplePatIn [VarPatIn con_field, VarPatIn res] Boxed)
898 (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt p))) draw_from)
901 result_expr = ExplicitTuple [con_expr, if null bs_needed
903 else HsVar (last bs_needed)] Boxed
905 [lp,rp] = getLRPrecs is_infix get_fixity dc_nm
908 | is_infix = let (h:t) = field_quals in (h:con_qual:t)
909 | otherwise = con_qual:field_quals
911 stmts = quals ++ [ReturnStmt result_expr]
914 c.f. Figure 18 in Haskell 1.1 report.
917 | not is_infix = defaultPrecedence
918 | otherwise = getPrecedence get_fixity dc_nm
920 read_paren_arg -- parens depend on precedence...
921 | nullary_con = false_Expr -- it's optional.
922 | otherwise = HsPar (genOpApp zz_a_Expr gt_RDR (HsLit (HsInt paren_prec_limit)))
925 %************************************************************************
927 \subsubsection{Generating @Show@ instance declarations}
929 %************************************************************************
932 gen_Show_binds :: (Name -> Maybe Fixity) -> TyCon -> RdrNameMonoBinds
934 gen_Show_binds get_fixity tycon
935 = shows_prec `AndMonoBinds` show_list
937 tycon_loc = getSrcLoc tycon
938 -----------------------------------------------------------------------
939 show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
940 (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 0)))))
941 -----------------------------------------------------------------------
942 shows_prec = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
945 | nullary_con = -- skip the showParen junk...
946 ASSERT(null bs_needed)
947 ([wildPat, con_pat], show_con)
950 showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt paren_prec_limit))))
951 (HsPar (nested_compose_Expr show_thingies)))
953 data_con_RDR = qual_orig_name data_con
954 con_arity = dataConSourceArity data_con
955 bs_needed = take con_arity bs_RDRs
956 con_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
957 nullary_con = con_arity == 0
958 labels = dataConFieldLabels data_con
959 lab_fields = length labels
961 dc_nm = getName data_con
962 dc_occ_nm = getOccName data_con
963 dc_occ_nm_str = occNameUserString dc_occ_nm
965 is_infix = isDataSymOcc dc_occ_nm
969 | is_infix = mk_showString_app (' ':dc_occ_nm_str)
970 | otherwise = mk_showString_app (dc_occ_nm_str ++ space_ocurly_maybe)
974 | lab_fields == 0 = " "
978 show_all con fs@(x:xs)
979 | is_infix = x:con:xs
983 | lab_fields > 0 = [mk_showString_app "}"]
986 con:fs ++ ccurly_maybe
988 show_thingies = show_all show_con real_show_thingies_with_labs
990 show_label l = mk_showString_app (the_name ++ "=")
992 occ_nm = getOccName (fieldLabelName l)
994 is_op = isSymOcc occ_nm
996 | is_op = '(':nm ++ ")"
999 nm = occNameUserString occ_nm
1002 mk_showString_app str = HsApp (HsVar showString_RDR)
1003 (HsLit (mkHsString str))
1005 prec_cons = getLRPrecs is_infix get_fixity dc_nm
1009 [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt p))) (HsVar b)
1010 | (p,b) <- zip prec_cons bs_needed ]
1012 [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
1015 real_show_thingies_with_labs
1016 | lab_fields == 0 = intersperse (HsVar showSpace_RDR) real_show_thingies
1017 | otherwise = --Assumption: no of fields == no of labelled fields
1018 -- (and in same order)
1020 intersperse ([mk_showString_app ","]) $ -- Using SLIT()s containing ,s spells trouble.
1021 zipWithEqual "gen_Show_binds"
1023 (map show_label labels)
1027 c.f. Figure 16 and 17 in Haskell 1.1 report
1030 | not is_infix = defaultPrecedence + 1
1031 | otherwise = getPrecedence get_fixity dc_nm + 1
1036 getLRPrecs :: Bool -> (Name -> Maybe Fixity) -> Name -> [Integer]
1037 getLRPrecs is_infix get_fixity nm = [lp, rp]
1040 Figuring out the fixities of the arguments to a constructor,
1041 cf. Figures 16-18 in Haskell 1.1 report.
1043 (con_left_assoc, con_right_assoc) = isLRAssoc get_fixity nm
1044 paren_con_prec = getPrecedence get_fixity nm
1047 | not is_infix = defaultPrecedence + 1
1048 | con_left_assoc = paren_con_prec
1049 | otherwise = paren_con_prec + 1
1052 | not is_infix = defaultPrecedence + 1
1053 | con_right_assoc = paren_con_prec
1054 | otherwise = paren_con_prec + 1
1056 defaultPrecedence :: Integer
1057 defaultPrecedence = fromInt maxPrecedence
1059 getPrecedence :: (Name -> Maybe Fixity) -> Name -> Integer
1060 getPrecedence get_fixity nm
1061 = case get_fixity nm of
1062 Just (Fixity x _) -> fromInt x
1063 other -> pprTrace "TcGenDeriv.getPrecedence" (ppr nm) defaultPrecedence
1065 isLRAssoc :: (Name -> Maybe Fixity) -> Name -> (Bool, Bool)
1066 isLRAssoc get_fixity nm =
1067 case get_fixity nm of
1068 Just (Fixity _ InfixN) -> (False, False)
1069 Just (Fixity _ InfixR) -> (False, True)
1070 Just (Fixity _ InfixL) -> (True, False)
1071 other -> pprPanic "TcGenDeriv.isLRAssoc" (ppr nm)
1073 isInfixOccName :: String -> Bool
1074 isInfixOccName str =
1081 %************************************************************************
1083 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1085 %************************************************************************
1090 con2tag_Foo :: Foo ... -> Int#
1091 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1092 maxtag_Foo :: Int -- ditto (NB: not unboxed)
1095 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1100 = GenCon2Tag | GenTag2Con | GenMaxTag
1102 gen_tag_n_con_monobind
1103 :: (RdrName, -- (proto)Name for the thing in question
1104 TyCon, -- tycon in question
1108 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1109 | lots_of_constructors
1110 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1111 [([VarPatIn a_RDR], HsApp getTag_Expr a_Expr)]
1114 = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
1117 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1119 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
1121 = ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
1123 pat = ConPatIn var_RDR (nOfThem (dataConSourceArity var) WildPatIn)
1124 var_RDR = qual_orig_name var
1126 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1127 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1128 [([ConPatIn mkInt_RDR [VarPatIn a_RDR]],
1129 ExprWithTySig (HsApp tagToEnum_Expr a_Expr)
1130 (HsTyVar (qual_orig_name tycon)))]
1132 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1133 = mk_easy_FunMonoBind (getSrcLoc tycon)
1134 rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
1136 max_tag = case (tyConDataCons tycon) of
1137 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1141 %************************************************************************
1143 \subsection{Utility bits for generating bindings}
1145 %************************************************************************
1147 @mk_easy_FunMonoBind fun pats binds expr@ generates:
1149 fun pat1 pat2 ... patN = expr where binds
1152 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
1153 multi-clause definitions; it generates:
1155 fun p1a p1b ... p1N = e1
1156 fun p2a p2b ... p2N = e2
1158 fun pMa pMb ... pMN = eM
1162 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
1163 -> [RdrNameMonoBinds] -> RdrNameHsExpr
1166 mk_easy_FunMonoBind loc fun pats binds expr
1167 = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
1169 mk_easy_Match loc pats binds expr
1170 = mk_match loc pats expr (mkMonoBind (andMonoBindList binds) [] Recursive)
1171 -- The renamer expects everything in its input to be a
1172 -- "recursive" MonoBinds, and it is its job to sort things out
1175 mk_FunMonoBind :: SrcLoc -> RdrName
1176 -> [([RdrNamePat], RdrNameHsExpr)]
1179 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
1180 mk_FunMonoBind loc fun pats_and_exprs
1181 = FunMonoBind fun False{-not infix-}
1182 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
1185 mk_match loc pats expr binds
1186 = Match [] (map paren pats) Nothing
1187 (GRHSs (unguardedRHS expr loc) binds Nothing)
1189 paren p@(VarPatIn _) = p
1190 paren other_p = ParPatIn other_p
1194 mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
1197 ToDo: Better SrcLocs.
1201 RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1202 -> RdrNameHsExpr -> RdrNameHsExpr
1206 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1207 -> RdrNameHsExpr -> RdrNameHsExpr
1209 careful_compare_Case :: -- checks for primitive types...
1211 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1212 -> RdrNameHsExpr -> RdrNameHsExpr
1215 compare_Case = compare_gen_Case compare_RDR
1216 cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b
1217 -- Was: compare_gen_Case cmp_eq_RDR
1219 compare_gen_Case fun lt eq gt a b
1220 = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
1221 [mkSimpleMatch [ConPatIn ltTag_RDR []] lt Nothing generatedSrcLoc,
1222 mkSimpleMatch [ConPatIn eqTag_RDR []] eq Nothing generatedSrcLoc,
1223 mkSimpleMatch [ConPatIn gtTag_RDR []] gt Nothing generatedSrcLoc]
1226 careful_compare_Case ty lt eq gt a b
1227 = if not (isUnboxedType ty) then
1228 compare_gen_Case compare_RDR lt eq gt a b
1230 else -- we have to do something special for primitive things...
1231 HsIf (genOpApp a relevant_eq_op b)
1233 (HsIf (genOpApp a relevant_lt_op b) lt gt generatedSrcLoc)
1236 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1237 relevant_lt_op = assoc_ty_id lt_op_tbl ty
1239 assoc_ty_id tyids ty
1240 = if null res then panic "assoc_ty"
1243 res = [id | (ty',id) <- tyids, ty == ty']
1246 [(charPrimTy, eqH_Char_RDR)
1247 ,(intPrimTy, eqH_Int_RDR)
1248 ,(wordPrimTy, eqH_Word_RDR)
1249 ,(addrPrimTy, eqH_Addr_RDR)
1250 ,(floatPrimTy, eqH_Float_RDR)
1251 ,(doublePrimTy, eqH_Double_RDR)
1255 [(charPrimTy, ltH_Char_RDR)
1256 ,(intPrimTy, ltH_Int_RDR)
1257 ,(wordPrimTy, ltH_Word_RDR)
1258 ,(addrPrimTy, ltH_Addr_RDR)
1259 ,(floatPrimTy, ltH_Float_RDR)
1260 ,(doublePrimTy, ltH_Double_RDR)
1263 -----------------------------------------------------------------------
1265 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1267 and_Expr a b = genOpApp a and_RDR b
1268 append_Expr a b = genOpApp a append_RDR b
1270 -----------------------------------------------------------------------
1272 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1274 = if not (isUnboxedType ty) then
1276 else -- we have to do something special for primitive things...
1277 genOpApp a relevant_eq_op b
1279 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1283 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
1284 untag_Expr tycon [] expr = expr
1285 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1286 = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1287 [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) Nothing generatedSrcLoc]
1290 cmp_tags_Expr :: RdrName -- Comparison op
1291 -> RdrName -> RdrName -- Things to compare
1292 -> RdrNameHsExpr -- What to return if true
1293 -> RdrNameHsExpr -- What to return if false
1296 cmp_tags_Expr op a b true_case false_case
1297 = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case generatedSrcLoc
1300 :: RdrNameHsExpr -> RdrNameHsExpr
1302 enum_from_then_to_Expr
1303 :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1306 enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1307 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1309 showParen_Expr, readParen_Expr
1310 :: RdrNameHsExpr -> RdrNameHsExpr
1313 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1314 readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_RDR) e1) e2
1316 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1318 nested_compose_Expr [e] = parenify e
1319 nested_compose_Expr (e:es)
1320 = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1322 -- impossible_Expr is used in case RHSs that should never happen.
1323 -- We generate these to keep the desugarer from complaining that they *might* happen!
1324 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ "Urk! in TcGenDeriv")))
1326 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1327 -- method. It is currently only used by Enum.{succ,pred}
1328 illegal_Expr meth tp msg =
1329 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ (meth ++ '{':tp ++ "}: " ++ msg))))
1331 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1332 -- to include the value of a_RDR in the error string.
1333 illegal_toEnum_tag tp maxtag =
1334 HsApp (HsVar error_RDR)
1335 (HsApp (HsApp (HsVar append_RDR)
1336 (HsLit (HsString (_PK_ ("toEnum{" ++ tp ++ "}: tag (")))))
1337 (HsApp (HsApp (HsApp
1338 (HsVar showsPrec_RDR)
1343 (HsLit (HsString (_PK_ ") is outside of enumeration's range (0,"))))
1344 (HsApp (HsApp (HsApp
1345 (HsVar showsPrec_RDR)
1348 (HsLit (HsString (_PK_ ")")))))))
1350 parenify e@(HsVar _) = e
1351 parenify e = HsPar e
1353 -- genOpApp wraps brackets round the operator application, so that the
1354 -- renamer won't subsequently try to re-associate it.
1355 -- For some reason the renamer doesn't reassociate it right, and I can't
1356 -- be bothered to find out why just now.
1358 genOpApp e1 op e2 = mkHsOpApp e1 op e2
1362 qual_orig_name n = nameRdrName (getName n)
1363 varUnqual n = mkUnqual varName n
1365 zz_a_RDR = varUnqual SLIT("_a")
1366 a_RDR = varUnqual SLIT("a")
1367 b_RDR = varUnqual SLIT("b")
1368 c_RDR = varUnqual SLIT("c")
1369 d_RDR = varUnqual SLIT("d")
1370 ah_RDR = varUnqual SLIT("a#")
1371 bh_RDR = varUnqual SLIT("b#")
1372 ch_RDR = varUnqual SLIT("c#")
1373 dh_RDR = varUnqual SLIT("d#")
1374 cmp_eq_RDR = varUnqual SLIT("cmp_eq")
1375 rangeSize_RDR = varUnqual SLIT("rangeSize")
1377 as_RDRs = [ varUnqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
1378 bs_RDRs = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
1379 cs_RDRs = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
1381 mkHsString s = HsString (_PK_ s)
1383 zz_a_Expr = HsVar zz_a_RDR
1384 a_Expr = HsVar a_RDR
1385 b_Expr = HsVar b_RDR
1386 c_Expr = HsVar c_RDR
1387 d_Expr = HsVar d_RDR
1388 ltTag_Expr = HsVar ltTag_RDR
1389 eqTag_Expr = HsVar eqTag_RDR
1390 gtTag_Expr = HsVar gtTag_RDR
1391 false_Expr = HsVar false_RDR
1392 true_Expr = HsVar true_RDR
1394 getTag_Expr = HsVar getTag_RDR
1395 tagToEnum_Expr = HsVar tagToEnumH_RDR
1396 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1399 zz_a_Pat = VarPatIn zz_a_RDR
1400 a_Pat = VarPatIn a_RDR
1401 b_Pat = VarPatIn b_RDR
1402 c_Pat = VarPatIn c_RDR
1403 d_Pat = VarPatIn d_RDR
1405 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1407 con2tag_RDR tycon = varUnqual (_PK_ ("con2tag_" ++ occNameString (getOccName tycon) ++ "#"))
1408 tag2con_RDR tycon = varUnqual (_PK_ ("tag2con_" ++ occNameString (getOccName tycon) ++ "#"))
1409 maxtag_RDR tycon = varUnqual (_PK_ ("maxtag_" ++ occNameString (getOccName tycon) ++ "#"))