2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcGenDeriv]{Generating derived instance declarations}
6 This module is nominally ``subordinate'' to @TcDeriv@, which is the
7 ``official'' interface to deriving-related things.
9 This is where we do all the grimy bindings' generation.
20 gen_tag_n_con_monobind,
22 con2tag_RDR, tag2con_RDR, maxtag_RDR,
27 #include "HsVersions.h"
29 import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..),
30 Match(..), GRHSs(..), Stmt(..), HsLit(..),
31 HsBinds(..), StmtCtxt(..), HsType(..),
32 unguardedRHS, mkSimpleMatch
34 import RdrHsSyn ( mkOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
35 import RdrName ( RdrName, mkSrcUnqual )
36 import RnMonad ( Fixities )
37 import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..) )
38 import FieldLabel ( fieldLabelName )
39 import DataCon ( isNullaryDataCon, dataConTag,
40 dataConRawArgTys, fIRST_TAG,
43 import Name ( getOccString, getOccName, getSrcLoc, occNameString,
44 occNameUserString, nameRdrName, varName,
45 OccName, Name, NamedThing(..), NameSpace
48 import PrimOp ( PrimOp(..) )
49 import PrelInfo -- Lots of RdrNames
50 import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
51 import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
52 maybeTyConSingleCon, tyConFamilySize
54 import Type ( isUnLiftedType, isUnboxedType, Type )
55 import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
56 floatPrimTy, doublePrimTy
58 import Util ( mapAccumL, zipEqual, zipWithEqual,
59 zipWith3Equal, nOfThem )
60 import Panic ( panic, assertPanic )
61 import Maybes ( maybeToBool, assocMaybe )
63 import List ( partition, intersperse )
66 %************************************************************************
68 \subsection{Generating code, by derivable class}
70 %************************************************************************
72 %************************************************************************
74 \subsubsection{Generating @Eq@ instance declarations}
76 %************************************************************************
78 Here are the heuristics for the code we generate for @Eq@:
81 Let's assume we have a data type with some (possibly zero) nullary
82 data constructors and some ordinary, non-nullary ones (the rest,
83 also possibly zero of them). Here's an example, with both \tr{N}ullary
84 and \tr{O}rdinary data cons.
86 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
90 For the ordinary constructors (if any), we emit clauses to do The
94 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
95 (==) (O2 a1) (O2 a2) = a1 == a2
96 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
99 Note: if we're comparing unboxed things, e.g., if \tr{a1} and
100 \tr{a2} are \tr{Float#}s, then we have to generate
102 case (a1 `eqFloat#` a2) of
105 for that particular test.
108 If there are any nullary constructors, we emit a catch-all clause of
112 (==) a b = case (con2tag_Foo a) of { a# ->
113 case (con2tag_Foo b) of { b# ->
114 case (a# ==# b#) of {
119 If there aren't any nullary constructors, we emit a simpler
126 For the @(/=)@ method, we normally just use the default method.
128 If the type is an enumeration type, we could/may/should? generate
129 special code that calls @con2tag_Foo@, much like for @(==)@ shown
133 We thought about doing this: If we're also deriving @Ord@ for this
136 instance ... Eq (Foo ...) where
137 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
138 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
140 However, that requires that \tr{Ord <whatever>} was put in the context
141 for the instance decl, which it probably wasn't, so the decls
142 produced don't get through the typechecker.
146 deriveEq :: RdrName -- Class
147 -> RdrName -- Type constructor
148 -> [ (RdrName, [RdrType]) ] -- Constructors
149 -> (RdrContext, -- Context for the inst decl
150 [RdrBind], -- Binds in the inst decl
151 [RdrBind]) -- Extra value bindings outside
153 deriveEq clas tycon constrs
154 = (context, [eq_bind, ne_bind], [])
156 context = [(clas, [ty]) | (_, tys) <- constrs, ty <- tys]
159 (nullary_cons, non_nullary_cons) = partition is_nullary constrs
160 is_nullary (_, args) = null args
163 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
167 tycon_loc = getSrcLoc tycon
168 (nullary_cons, nonnullary_cons)
169 | isNewTyCon tycon = ([], tyConDataCons tycon)
170 | otherwise = partition isNullaryDataCon (tyConDataCons tycon)
173 = if (null nullary_cons) then
174 case maybeTyConSingleCon tycon of
176 Nothing -> -- if cons don't match, then False
177 [([wildPat, wildPat], false_Expr)]
178 else -- calc. and compare the tags
180 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
181 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR true_Expr false_Expr))]
183 mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
185 mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
186 HsApp (HsVar not_RDR) (HsPar (mk_easy_App eq_RDR [a_RDR, b_RDR])))
188 ------------------------------------------------------------------
191 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
192 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
194 data_con_RDR = qual_orig_name data_con
195 con_arity = length tys_needed
196 as_needed = take con_arity as_RDRs
197 bs_needed = take con_arity bs_RDRs
198 tys_needed = dataConRawArgTys data_con
200 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
202 nested_eq_expr [] [] [] = true_Expr
203 nested_eq_expr tys as bs
204 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
206 nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
209 %************************************************************************
211 \subsubsection{Generating @Ord@ instance declarations}
213 %************************************************************************
215 For a derived @Ord@, we concentrate our attentions on @compare@
217 compare :: a -> a -> Ordering
218 data Ordering = LT | EQ | GT deriving ()
221 We will use the same example data type as above:
223 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
228 We do all the other @Ord@ methods with calls to @compare@:
230 instance ... (Ord <wurble> <wurble>) where
231 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
232 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
233 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
234 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
236 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
237 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
239 -- compare to come...
243 @compare@ always has two parts. First, we use the compared
244 data-constructors' tags to deal with the case of different
247 compare a b = case (con2tag_Foo a) of { a# ->
248 case (con2tag_Foo b) of { b# ->
249 case (a# ==# b#) of {
251 False -> case (a# <# b#) of
256 cmp_eq = ... to come ...
260 We are only left with the ``help'' function @cmp_eq@, to deal with
261 comparing data constructors with the same tag.
263 For the ordinary constructors (if any), we emit the sorta-obvious
264 compare-style stuff; for our example:
266 cmp_eq (O1 a1 b1) (O1 a2 b2)
267 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
269 cmp_eq (O2 a1) (O2 a2)
272 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
273 = case (compare a1 a2) of {
276 EQ -> case compare b1 b2 of {
284 Again, we must be careful about unboxed comparisons. For example,
285 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
289 cmp_eq lt eq gt (O2 a1) (O2 a2)
291 -- or maybe the unfolded equivalent
295 For the remaining nullary constructors, we already know that the
302 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
306 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
309 = compare -- `AndMonoBinds` compare
310 -- The default declaration in PrelBase handles this
312 tycon_loc = getSrcLoc tycon
313 --------------------------------------------------------------------
314 compare = mk_easy_FunMonoBind tycon_loc compare_RDR
317 (if maybeToBool (maybeTyConSingleCon tycon) then
319 -- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
320 -- Wierd. Was: case (cmp a b) of { LT -> LT; EQ -> EQ; GT -> GT }
322 cmp_eq_Expr a_Expr b_Expr
324 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
325 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR
326 -- True case; they are equal
327 -- If an enumeration type we are done; else
328 -- recursively compare their components
329 (if isEnumerationTyCon tycon then
332 -- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
334 cmp_eq_Expr a_Expr b_Expr
336 -- False case; they aren't equal
337 -- So we need to do a less-than comparison on the tags
338 (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
340 tycon_data_cons = tyConDataCons tycon
341 (nullary_cons, nonnullary_cons)
342 | isNewTyCon tycon = ([], tyConDataCons tycon)
343 | otherwise = partition isNullaryDataCon tycon_data_cons
346 mk_FunMonoBind tycon_loc
348 (if null nonnullary_cons && (length nullary_cons == 1) then
349 -- catch this specially to avoid warnings
350 -- about overlapping patterns from the desugarer.
352 data_con = head nullary_cons
353 data_con_RDR = qual_orig_name data_con
354 pat = ConPatIn data_con_RDR []
356 [([pat,pat], eqTag_Expr)]
358 map pats_etc nonnullary_cons ++
359 -- leave out wildcards to silence desugarer.
360 (if length tycon_data_cons == 1 then
363 [([WildPatIn, WildPatIn], default_rhs)]))
366 = ([con1_pat, con2_pat],
367 nested_compare_expr tys_needed as_needed bs_needed)
369 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
370 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
372 data_con_RDR = qual_orig_name data_con
373 con_arity = length tys_needed
374 as_needed = take con_arity as_RDRs
375 bs_needed = take con_arity bs_RDRs
376 tys_needed = dataConRawArgTys data_con
378 nested_compare_expr [ty] [a] [b]
379 = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
381 nested_compare_expr (ty:tys) (a:as) (b:bs)
382 = let eq_expr = nested_compare_expr tys as bs
383 in careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
385 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
386 -- inexhaustive patterns
387 | otherwise = eqTag_Expr -- Some nullary constructors;
388 -- Tags are equal, no args => return EQ
389 --------------------------------------------------------------------
391 {- Not necessary: the default decls in PrelBase handle these
393 defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
395 lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] (
396 compare_Case true_Expr false_Expr false_Expr a_Expr b_Expr)
397 le = mk_easy_FunMonoBind mkGeneratedSrcLoc le_RDR [a_Pat, b_Pat] [] (
398 compare_Case true_Expr true_Expr false_Expr a_Expr b_Expr)
399 ge = mk_easy_FunMonoBind mkGeneratedSrcLoc ge_RDR [a_Pat, b_Pat] [] (
400 compare_Case false_Expr true_Expr true_Expr a_Expr b_Expr)
401 gt = mk_easy_FunMonoBind mkGeneratedSrcLoc gt_RDR [a_Pat, b_Pat] [] (
402 compare_Case false_Expr false_Expr true_Expr a_Expr b_Expr)
404 max_ = mk_easy_FunMonoBind mkGeneratedSrcLoc max_RDR [a_Pat, b_Pat] [] (
405 compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
406 min_ = mk_easy_FunMonoBind mkGeneratedSrcLoc min_RDR [a_Pat, b_Pat] [] (
407 compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
411 %************************************************************************
413 \subsubsection{Generating @Enum@ instance declarations}
415 %************************************************************************
417 @Enum@ can only be derived for enumeration types. For a type
419 data Foo ... = N1 | N2 | ... | Nn
422 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
423 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
426 instance ... Enum (Foo ...) where
427 succ x = toEnum (1 + fromEnum x)
428 pred x = toEnum (fromEnum x - 1)
430 toEnum i = tag2con_Foo i
432 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
436 = case con2tag_Foo a of
437 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
440 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
444 = case con2tag_Foo a of { a# ->
445 case con2tag_Foo b of { b# ->
446 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
450 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
453 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
456 = succ_enum `AndMonoBinds`
457 pred_enum `AndMonoBinds`
458 to_enum `AndMonoBinds`
459 enum_from `AndMonoBinds`
460 enum_from_then `AndMonoBinds`
463 tycon_loc = getSrcLoc tycon
464 occ_nm = getOccString tycon
467 = mk_easy_FunMonoBind tycon_loc succ_RDR [a_Pat] [] $
468 untag_Expr tycon [(a_RDR, ah_RDR)] $
469 HsIf (HsApp (HsApp (HsVar eq_RDR)
470 (HsVar (maxtag_RDR tycon)))
471 (mk_easy_App mkInt_RDR [ah_RDR]))
472 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
473 (HsApp (HsVar (tag2con_RDR tycon))
474 (HsApp (HsApp (HsVar plus_RDR)
475 (mk_easy_App mkInt_RDR [ah_RDR]))
480 = mk_easy_FunMonoBind tycon_loc pred_RDR [a_Pat] [] $
481 untag_Expr tycon [(a_RDR, ah_RDR)] $
482 HsIf (HsApp (HsApp (HsVar eq_RDR) (HsLit (HsInt 0)))
483 (mk_easy_App mkInt_RDR [ah_RDR]))
484 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
485 (HsApp (HsVar (tag2con_RDR tycon))
486 (HsApp (HsApp (HsVar plus_RDR)
487 (mk_easy_App mkInt_RDR [ah_RDR]))
488 (HsLit (HsInt (-1)))))
492 = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
495 (HsApp (HsApp (HsVar ge_RDR)
498 (HsApp (HsApp (HsVar le_RDR)
500 (HsVar (maxtag_RDR tycon))))
501 (mk_easy_App (tag2con_RDR tycon) [a_RDR])
502 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
506 = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
507 untag_Expr tycon [(a_RDR, ah_RDR)] $
508 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
509 HsPar (enum_from_to_Expr
510 (mk_easy_App mkInt_RDR [ah_RDR])
511 (HsVar (maxtag_RDR tycon)))
514 = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
515 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
516 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
517 HsPar (enum_from_then_to_Expr
518 (mk_easy_App mkInt_RDR [ah_RDR])
519 (mk_easy_App mkInt_RDR [bh_RDR])
520 (HsIf (HsApp (HsApp (HsVar gt_RDR)
521 (mk_easy_App mkInt_RDR [ah_RDR]))
522 (mk_easy_App mkInt_RDR [bh_RDR]))
524 (HsVar (maxtag_RDR tycon))
528 = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
529 untag_Expr tycon [(a_RDR, ah_RDR)] $
530 (mk_easy_App mkInt_RDR [ah_RDR])
533 %************************************************************************
535 \subsubsection{Generating @Bounded@ instance declarations}
537 %************************************************************************
540 gen_Bounded_binds tycon
541 = if isEnumerationTyCon tycon then
542 min_bound_enum `AndMonoBinds` max_bound_enum
544 ASSERT(length data_cons == 1)
545 min_bound_1con `AndMonoBinds` max_bound_1con
547 data_cons = tyConDataCons tycon
548 tycon_loc = getSrcLoc tycon
550 ----- enum-flavored: ---------------------------
551 min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
552 max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR)
554 data_con_1 = head data_cons
555 data_con_N = last data_cons
556 data_con_1_RDR = qual_orig_name data_con_1
557 data_con_N_RDR = qual_orig_name data_con_N
559 ----- single-constructor-flavored: -------------
560 arity = argFieldCount data_con_1
562 min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
563 mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
564 max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
565 mk_easy_App data_con_1_RDR (nOfThem arity maxBound_RDR)
568 %************************************************************************
570 \subsubsection{Generating @Ix@ instance declarations}
572 %************************************************************************
574 Deriving @Ix@ is only possible for enumeration types and
575 single-constructor types. We deal with them in turn.
577 For an enumeration type, e.g.,
579 data Foo ... = N1 | N2 | ... | Nn
581 things go not too differently from @Enum@:
583 instance ... Ix (Foo ...) where
585 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
589 = case (con2tag_Foo a) of { a# ->
590 case (con2tag_Foo b) of { b# ->
591 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
596 then case (con2tag_Foo d -# con2tag_Foo a) of
598 else error "Ix.Foo.index: out of range"
602 p_tag = con2tag_Foo c
604 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
608 = case (con2tag_Foo a) of { a_tag ->
609 case (con2tag_Foo b) of { b_tag ->
610 case (con2tag_Foo c) of { c_tag ->
611 if (c_tag >=# a_tag) then
617 (modulo suitable case-ification to handle the unboxed tags)
619 For a single-constructor type (NB: this includes all tuples), e.g.,
621 data Foo ... = MkFoo a b Int Double c c
623 we follow the scheme given in Figure~19 of the Haskell~1.2 report
627 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
630 = if isEnumerationTyCon tycon
634 tycon_str = getOccString tycon
635 tycon_loc = getSrcLoc tycon
637 --------------------------------------------------------------
638 enum_ixes = enum_range `AndMonoBinds`
639 enum_index `AndMonoBinds` enum_inRange
642 = mk_easy_FunMonoBind tycon_loc range_RDR
643 [TuplePatIn [a_Pat, b_Pat] True{-boxed-}] [] $
644 untag_Expr tycon [(a_RDR, ah_RDR)] $
645 untag_Expr tycon [(b_RDR, bh_RDR)] $
646 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
647 HsPar (enum_from_to_Expr
648 (mk_easy_App mkInt_RDR [ah_RDR])
649 (mk_easy_App mkInt_RDR [bh_RDR]))
652 = mk_easy_FunMonoBind tycon_loc index_RDR
653 [AsPatIn c_RDR (TuplePatIn [a_Pat, wildPat] True{-boxed-}),
655 HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
656 untag_Expr tycon [(a_RDR, ah_RDR)] (
657 untag_Expr tycon [(d_RDR, dh_RDR)] (
659 rhs = mk_easy_App mkInt_RDR [c_RDR]
662 (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
663 [mkSimpleMatch [VarPatIn c_RDR] rhs Nothing tycon_loc]
667 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
672 = mk_easy_FunMonoBind tycon_loc inRange_RDR
673 [TuplePatIn [a_Pat, b_Pat] True{-boxed-}, c_Pat] [] (
674 untag_Expr tycon [(a_RDR, ah_RDR)] (
675 untag_Expr tycon [(b_RDR, bh_RDR)] (
676 untag_Expr tycon [(c_RDR, ch_RDR)] (
677 HsIf (genOpApp (HsVar ch_RDR) geH_RDR (HsVar ah_RDR)) (
678 (genOpApp (HsVar ch_RDR) leH_RDR (HsVar bh_RDR))
683 --------------------------------------------------------------
685 = single_con_range `AndMonoBinds`
686 single_con_index `AndMonoBinds`
690 = case maybeTyConSingleCon tycon of -- just checking...
691 Nothing -> panic "get_Ix_binds"
692 Just dc -> if (any isUnLiftedType (dataConRawArgTys dc)) then
693 error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
697 con_arity = argFieldCount data_con
698 data_con_RDR = qual_orig_name data_con
700 as_needed = take con_arity as_RDRs
701 bs_needed = take con_arity bs_RDRs
702 cs_needed = take con_arity cs_RDRs
704 con_pat xs = ConPatIn data_con_RDR (map VarPatIn xs)
705 con_expr = mk_easy_App data_con_RDR cs_needed
707 --------------------------------------------------------------
709 = mk_easy_FunMonoBind tycon_loc range_RDR
710 [TuplePatIn [con_pat as_needed, con_pat bs_needed] True{-boxed-}] [] $
711 HsDo ListComp stmts tycon_loc
713 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
715 [ReturnStmt con_expr]
717 mk_qual a b c = BindStmt (VarPatIn c)
718 (HsApp (HsVar range_RDR)
719 (ExplicitTuple [HsVar a, HsVar b] True))
724 = mk_easy_FunMonoBind tycon_loc index_RDR
725 [TuplePatIn [con_pat as_needed, con_pat bs_needed] True,
726 con_pat cs_needed] [range_size] (
727 foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
729 mk_index multiply_by (l, u, i)
731 (HsApp (HsApp (HsVar index_RDR)
732 (ExplicitTuple [HsVar l, HsVar u] True)) (HsVar i))
735 (HsApp (HsVar rangeSize_RDR)
736 (ExplicitTuple [HsVar l, HsVar u] True))
737 ) times_RDR multiply_by
741 = mk_easy_FunMonoBind tycon_loc rangeSize_RDR
742 [TuplePatIn [a_Pat, b_Pat] True] [] (
744 (HsApp (HsApp (HsVar index_RDR)
745 (ExplicitTuple [a_Expr, b_Expr] True)) b_Expr)
746 ) plus_RDR (HsLit (HsInt 1)))
750 = mk_easy_FunMonoBind tycon_loc inRange_RDR
751 [TuplePatIn [con_pat as_needed, con_pat bs_needed] True,
754 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
756 in_range a b c = HsApp (HsApp (HsVar inRange_RDR)
757 (ExplicitTuple [HsVar a, HsVar b] True))
761 %************************************************************************
763 \subsubsection{Generating @Read@ instance declarations}
765 %************************************************************************
768 gen_Read_binds :: Fixities -> TyCon -> RdrNameMonoBinds
770 gen_Read_binds fixities tycon
771 = reads_prec `AndMonoBinds` read_list
773 tycon_loc = getSrcLoc tycon
774 -----------------------------------------------------------------------
775 read_list = mk_easy_FunMonoBind tycon_loc readList_RDR [] []
776 (HsApp (HsVar readList___RDR) (HsPar (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 0)))))
777 -----------------------------------------------------------------------
780 read_con_comprehensions
781 = map read_con (tyConDataCons tycon)
783 mk_easy_FunMonoBind tycon_loc readsPrec_RDR [_a_Pat, b_Pat] [] (
784 foldr1 append_Expr read_con_comprehensions
787 read_con data_con -- note: "b" is the string being "read"
789 readParen_Expr read_paren_arg $ HsPar $
790 HsLam (mk_easy_Match tycon_loc [c_Pat] [] $
791 HsDo ListComp stmts tycon_loc)
794 data_con_RDR = qual_orig_name data_con
795 data_con_str = occNameUserString (getOccName data_con)
796 con_arity = argFieldCount data_con
797 con_expr = mk_easy_App data_con_RDR as_needed
798 nullary_con = con_arity == 0
799 labels = dataConFieldLabels data_con
800 lab_fields = length labels
801 dc_nm = getName data_con
802 is_infix = isInfixOccName data_con_str
804 as_needed = take con_arity as_RDRs
806 | is_infix = take (1 + con_arity) bs_RDRs
807 | lab_fields == 0 = take con_arity bs_RDRs
808 | otherwise = take (4*lab_fields + 1) bs_RDRs
809 -- (label, '=' and field)*n, (n-1)*',' + '{' + '}'
811 (as1:as2:_) = as_needed
812 (bs1:bs2:bs3:_) = bs_needed
817 (TuplePatIn [LitPatIn (mkHsString data_con_str), d_Pat] True)
818 (HsApp (HsVar lex_RDR) c_Expr)
822 (TuplePatIn [LitPatIn (mkHsString data_con_str), VarPatIn bs2] True)
823 (HsApp (HsVar lex_RDR) (HsVar bs1))
827 str_qual str res draw_from =
829 (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] True)
830 (HsApp (HsVar lex_RDR) draw_from)
833 read_label f = [str_qual nm, str_qual "="]
834 -- There might be spaces between the label and '='
836 nm = occNameUserString (getOccName (fieldLabelName f))
840 snd (mapAccumL mk_qual_infix
842 [ (mk_read_qual lp as1, bs1, bs2)
843 , (mk_read_qual rp as2, bs3, bs3)
845 | lab_fields == 0 = -- common case.
846 snd (mapAccumL mk_qual
848 (zipWithEqual "as_needed"
849 (\ con_field draw_from -> (mk_read_qual 10 con_field,
851 as_needed bs_needed))
854 mapAccumL mk_qual d_Expr
855 (zipEqual "bs_needed"
858 intersperse [str_qual ","] $
861 (\ as b -> as ++ [b])
863 (map read_label labels)
865 (map (mk_read_qual 10) as_needed))) ++ [str_qual "}"])
868 mk_qual_infix draw_from (f, str_left, str_left2) =
869 (HsVar str_left2, -- what to draw from down the line...
870 f str_left draw_from)
872 mk_qual draw_from (f, str_left) =
873 (HsVar str_left, -- what to draw from down the line...
874 f str_left draw_from)
876 mk_read_qual p con_field res draw_from =
878 (TuplePatIn [VarPatIn con_field, VarPatIn res] True)
879 (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt p))) draw_from)
882 result_expr = ExplicitTuple [con_expr, if null bs_needed
884 else HsVar (last bs_needed)] True
886 [lp,rp] = getLRPrecs fixities dc_nm
889 | is_infix = let (h:t) = field_quals in (h:con_qual:t)
890 | otherwise = con_qual:field_quals
892 stmts = quals ++ [ReturnStmt result_expr]
896 | otherwise = getFixity fixities dc_nm
898 read_paren_arg -- parens depend on precedence...
899 | nullary_con = false_Expr -- it's optional.
900 | otherwise = HsPar (genOpApp _a_Expr gt_RDR (HsLit (HsInt paren_prec_limit)))
903 %************************************************************************
905 \subsubsection{Generating @Show@ instance declarations}
907 %************************************************************************
910 gen_Show_binds :: Fixities -> TyCon -> RdrNameMonoBinds
912 gen_Show_binds fixs_assoc tycon
913 = shows_prec `AndMonoBinds` show_list
915 tycon_loc = getSrcLoc tycon
916 -----------------------------------------------------------------------
917 show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
918 (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 0)))))
919 -----------------------------------------------------------------------
920 shows_prec = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
923 | nullary_con = -- skip the showParen junk...
924 ASSERT(null bs_needed)
925 ([wildPat, con_pat], show_con)
928 showParen_Expr (HsPar (genOpApp a_Expr gt_RDR (HsLit (HsInt paren_prec_limit))))
929 (HsPar (nested_compose_Expr show_thingies)))
931 data_con_RDR = qual_orig_name data_con
932 con_arity = argFieldCount data_con
933 bs_needed = take con_arity bs_RDRs
934 con_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
935 nullary_con = con_arity == 0
936 labels = dataConFieldLabels data_con
937 lab_fields = length labels
939 dc_occ_nm = occNameUserString (getOccName data_con)
940 dc_nm = getName data_con
942 is_infix = isInfixOccName dc_occ_nm
946 | is_infix = mk_showString_app (' ':dc_occ_nm)
951 | lab_fields == 0 = " "
954 mk_showString_app (dc_occ_nm ++ space_ocurly_maybe)
956 show_all con fs@(x:xs)
957 | is_infix = x:con:xs
961 | lab_fields > 0 = [mk_showString_app "}"]
964 con:fs ++ ccurly_maybe
966 show_thingies = show_all show_con real_show_thingies_with_labs
968 show_label l = mk_showString_app (nm ++ "=")
970 nm = occNameUserString (getOccName (fieldLabelName l))
973 mk_showString_app str = HsApp (HsVar showString_RDR)
974 (HsLit (mkHsString str))
976 prec_cons = getLRPrecs fixs_assoc dc_nm
980 [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt p))) (HsVar b)
981 | (p,b) <- zip prec_cons bs_needed ]
983 [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
986 real_show_thingies_with_labs
987 | lab_fields == 0 = intersperse (HsVar showSpace_RDR) real_show_thingies
988 | otherwise = --Assumption: no of fields == no of labelled fields
989 -- (and in same order)
991 intersperse ([mk_showString_app ","]) $ -- Using SLIT()s containing ,s spells trouble.
992 zipWithEqual "gen_Show_binds"
994 (map show_label labels)
997 (con_left_assoc, con_right_assoc) = isLRAssoc fixs_assoc dc_nm
1001 | otherwise = getFixity fixs_assoc dc_nm
1006 getLRPrecs :: Fixities -> Name -> [Integer]
1007 getLRPrecs fixs_assoc nm = [lp, rp]
1009 ( con_left_assoc, con_right_assoc) = isLRAssoc fixs_assoc nm
1010 paren_prec_limit = 9
1013 | con_left_assoc = paren_prec_limit
1014 | otherwise = paren_prec_limit + 1
1017 | con_right_assoc = paren_prec_limit
1018 | otherwise = paren_prec_limit + 1
1021 getFixity :: Fixities -> Name -> Integer
1022 getFixity fixs_assoc nm =
1023 case assocMaybe fixs_assoc nm of
1025 Just (Fixity x _) -> fromInt x + 1
1027 isLRAssoc :: Fixities -> Name -> (Bool, Bool)
1028 isLRAssoc fixs_assoc nm =
1029 case assocMaybe fixs_assoc nm of
1030 Just (Fixity _ InfixL) -> (True, False)
1031 Just (Fixity _ InfixR) -> (False, True)
1034 isInfixOccName :: String -> Bool
1035 isInfixOccName str =
1043 %************************************************************************
1045 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1047 %************************************************************************
1052 con2tag_Foo :: Foo ... -> Int#
1053 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1054 maxtag_Foo :: Int -- ditto (NB: not unboxed)
1057 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1062 = GenCon2Tag | GenTag2Con | GenMaxTag
1064 gen_tag_n_con_monobind
1065 :: (RdrName, -- (proto)Name for the thing in question
1066 TyCon, -- tycon in question
1070 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1071 | lots_of_constructors
1072 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1073 [([VarPatIn a_RDR], HsApp getTag_Expr a_Expr)]
1076 = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
1079 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1081 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
1083 = ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
1085 pat = ConPatIn var_RDR (nOfThem (argFieldCount var) WildPatIn)
1086 var_RDR = qual_orig_name var
1088 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1089 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1090 [([ConPatIn mkInt_RDR [VarPatIn a_RDR]],
1091 ExprWithTySig (HsApp tagToEnum_Expr a_Expr)
1092 (MonoTyVar (qual_orig_name tycon)))]
1094 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1095 = mk_easy_FunMonoBind (getSrcLoc tycon)
1096 rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
1098 max_tag = case (tyConDataCons tycon) of
1099 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1103 %************************************************************************
1105 \subsection{Utility bits for generating bindings}
1107 %************************************************************************
1109 @mk_easy_FunMonoBind fun pats binds expr@ generates:
1111 fun pat1 pat2 ... patN = expr where binds
1114 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
1115 multi-clause definitions; it generates:
1117 fun p1a p1b ... p1N = e1
1118 fun p2a p2b ... p2N = e2
1120 fun pMa pMb ... pMN = eM
1124 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
1125 -> [RdrNameMonoBinds] -> RdrNameHsExpr
1128 mk_easy_FunMonoBind loc fun pats binds expr
1129 = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
1131 mk_easy_Match loc pats binds expr
1132 = mk_match loc pats expr (mkbind binds)
1134 mkbind [] = EmptyBinds
1135 mkbind bs = MonoBind (foldr1 AndMonoBinds bs) [] Recursive
1136 -- The renamer expects everything in its input to be a
1137 -- "recursive" MonoBinds, and it is its job to sort things out
1140 mk_FunMonoBind :: SrcLoc -> RdrName
1141 -> [([RdrNamePat], RdrNameHsExpr)]
1144 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
1145 mk_FunMonoBind loc fun pats_and_exprs
1146 = FunMonoBind fun False{-not infix-}
1147 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
1150 mk_match loc pats expr binds
1151 = Match [] (map paren pats) Nothing
1152 (GRHSs (unguardedRHS expr loc) binds Nothing)
1154 paren p@(VarPatIn _) = p
1155 paren other_p = ParPatIn other_p
1159 mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
1162 ToDo: Better SrcLocs.
1166 RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1167 -> RdrNameHsExpr -> RdrNameHsExpr
1171 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1172 -> RdrNameHsExpr -> RdrNameHsExpr
1174 careful_compare_Case :: -- checks for primitive types...
1176 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1177 -> RdrNameHsExpr -> RdrNameHsExpr
1180 compare_Case = compare_gen_Case compare_RDR
1181 cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b
1182 -- Was: compare_gen_Case cmp_eq_RDR
1184 compare_gen_Case fun lt eq gt a b
1185 = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
1186 [mkSimpleMatch [ConPatIn ltTag_RDR []] lt Nothing mkGeneratedSrcLoc,
1187 mkSimpleMatch [ConPatIn eqTag_RDR []] eq Nothing mkGeneratedSrcLoc,
1188 mkSimpleMatch [ConPatIn gtTag_RDR []] gt Nothing mkGeneratedSrcLoc]
1191 careful_compare_Case ty lt eq gt a b
1192 = if not (isUnboxedType ty) then
1193 compare_gen_Case compare_RDR lt eq gt a b
1195 else -- we have to do something special for primitive things...
1196 HsIf (genOpApp a relevant_eq_op b)
1198 (HsIf (genOpApp a relevant_lt_op b) lt gt mkGeneratedSrcLoc)
1201 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1202 relevant_lt_op = assoc_ty_id lt_op_tbl ty
1204 assoc_ty_id tyids ty
1205 = if null res then panic "assoc_ty"
1208 res = [id | (ty',id) <- tyids, ty == ty']
1211 [(charPrimTy, eqH_Char_RDR)
1212 ,(intPrimTy, eqH_Int_RDR)
1213 ,(wordPrimTy, eqH_Word_RDR)
1214 ,(addrPrimTy, eqH_Addr_RDR)
1215 ,(floatPrimTy, eqH_Float_RDR)
1216 ,(doublePrimTy, eqH_Double_RDR)
1220 [(charPrimTy, ltH_Char_RDR)
1221 ,(intPrimTy, ltH_Int_RDR)
1222 ,(wordPrimTy, ltH_Word_RDR)
1223 ,(addrPrimTy, ltH_Addr_RDR)
1224 ,(floatPrimTy, ltH_Float_RDR)
1225 ,(doublePrimTy, ltH_Double_RDR)
1228 -----------------------------------------------------------------------
1230 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1232 and_Expr a b = genOpApp a and_RDR b
1233 append_Expr a b = genOpApp a append_RDR b
1235 -----------------------------------------------------------------------
1237 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1239 = if not (isUnboxedType ty) then
1241 else -- we have to do something special for primitive things...
1242 genOpApp a relevant_eq_op b
1244 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1248 argFieldCount :: DataCon -> Int -- Works on data and newtype constructors
1249 argFieldCount con = length (dataConRawArgTys con)
1253 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
1254 untag_Expr tycon [] expr = expr
1255 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1256 = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1257 [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) Nothing mkGeneratedSrcLoc]
1260 cmp_tags_Expr :: RdrName -- Comparison op
1261 -> RdrName -> RdrName -- Things to compare
1262 -> RdrNameHsExpr -- What to return if true
1263 -> RdrNameHsExpr -- What to return if false
1266 cmp_tags_Expr op a b true_case false_case
1267 = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case mkGeneratedSrcLoc
1270 :: RdrNameHsExpr -> RdrNameHsExpr
1272 enum_from_then_to_Expr
1273 :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1276 enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1277 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1279 showParen_Expr, readParen_Expr
1280 :: RdrNameHsExpr -> RdrNameHsExpr
1283 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1284 readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_RDR) e1) e2
1286 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1288 nested_compose_Expr [e] = parenify e
1289 nested_compose_Expr (e:es)
1290 = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1292 -- impossible_Expr is used in case RHSs that should never happen.
1293 -- We generate these to keep the desugarer from complaining that they *might* happen!
1294 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ "Urk! in TcGenDeriv")))
1296 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1297 -- method. It is currently only used by Enum.{succ,pred}
1298 illegal_Expr meth tp msg =
1299 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ (meth ++ '{':tp ++ "}: " ++ msg))))
1301 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1302 -- to include the value of a_RDR in the error string.
1303 illegal_toEnum_tag tp maxtag =
1304 HsApp (HsVar error_RDR)
1305 (HsApp (HsApp (HsVar append_RDR)
1306 (HsLit (HsString (_PK_ ("toEnum{" ++ tp ++ "}: tag (")))))
1307 (HsApp (HsApp (HsApp
1308 (HsVar showsPrec_RDR)
1313 (HsLit (HsString (_PK_ ") is outside of enumeration's range (0,"))))
1314 (HsApp (HsApp (HsApp
1315 (HsVar showsPrec_RDR)
1318 (HsLit (HsString (_PK_ ")")))))))
1320 parenify e@(HsVar _) = e
1321 parenify e = HsPar e
1323 -- genOpApp wraps brackets round the operator application, so that the
1324 -- renamer won't subsequently try to re-associate it.
1325 -- For some reason the renamer doesn't reassociate it right, and I can't
1326 -- be bothered to find out why just now.
1328 genOpApp e1 op e2 = mkOpApp e1 op e2
1332 qual_orig_name n = nameRdrName (getName n)
1333 varUnqual n = mkSrcUnqual varName n
1335 _a_RDR = varUnqual SLIT("_a")
1336 a_RDR = varUnqual SLIT("a")
1337 b_RDR = varUnqual SLIT("b")
1338 c_RDR = varUnqual SLIT("c")
1339 d_RDR = varUnqual SLIT("d")
1340 ah_RDR = varUnqual SLIT("a#")
1341 bh_RDR = varUnqual SLIT("b#")
1342 ch_RDR = varUnqual SLIT("c#")
1343 dh_RDR = varUnqual SLIT("d#")
1344 cmp_eq_RDR = varUnqual SLIT("cmp_eq")
1345 rangeSize_RDR = varUnqual SLIT("rangeSize")
1347 as_RDRs = [ varUnqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
1348 bs_RDRs = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
1349 cs_RDRs = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
1351 mkHsString s = HsString (_PK_ s)
1353 _a_Expr = HsVar _a_RDR
1354 a_Expr = HsVar a_RDR
1355 b_Expr = HsVar b_RDR
1356 c_Expr = HsVar c_RDR
1357 d_Expr = HsVar d_RDR
1358 ltTag_Expr = HsVar ltTag_RDR
1359 eqTag_Expr = HsVar eqTag_RDR
1360 gtTag_Expr = HsVar gtTag_RDR
1361 false_Expr = HsVar false_RDR
1362 true_Expr = HsVar true_RDR
1364 getTag_Expr = HsVar getTag_RDR
1365 tagToEnum_Expr = HsVar tagToEnumH_RDR
1366 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1369 _a_Pat = VarPatIn _a_RDR
1370 a_Pat = VarPatIn a_RDR
1371 b_Pat = VarPatIn b_RDR
1372 c_Pat = VarPatIn c_RDR
1373 d_Pat = VarPatIn d_RDR
1375 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1377 con2tag_RDR tycon = varUnqual (_PK_ ("con2tag_" ++ occNameString (getOccName tycon) ++ "#"))
1378 tag2con_RDR tycon = varUnqual (_PK_ ("tag2con_" ++ occNameString (getOccName tycon) ++ "#"))
1379 maxtag_RDR tycon = varUnqual (_PK_ ("maxtag_" ++ occNameString (getOccName tycon) ++ "#"))