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 [([a_Pat, b_Pat], 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, b_Pat] 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)))
904 %************************************************************************
906 \subsubsection{Generating @Show@ instance declarations}
908 %************************************************************************
911 gen_Show_binds :: Fixities -> TyCon -> RdrNameMonoBinds
913 gen_Show_binds fixs_assoc tycon
914 = shows_prec `AndMonoBinds` show_list
916 tycon_loc = getSrcLoc tycon
917 -----------------------------------------------------------------------
918 show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
919 (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 0)))))
920 -----------------------------------------------------------------------
921 shows_prec = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
924 | nullary_con = -- skip the showParen junk...
925 ASSERT(null bs_needed)
926 ([a_Pat, con_pat], show_con)
929 showParen_Expr (HsPar (genOpApp a_Expr gt_RDR (HsLit (HsInt paren_prec_limit))))
930 (HsPar (nested_compose_Expr show_thingies)))
932 data_con_RDR = qual_orig_name data_con
933 con_arity = argFieldCount data_con
934 bs_needed = take con_arity bs_RDRs
935 con_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
936 nullary_con = con_arity == 0
937 labels = dataConFieldLabels data_con
938 lab_fields = length labels
940 dc_occ_nm = occNameUserString (getOccName data_con)
941 dc_nm = getName data_con
943 is_infix = isInfixOccName dc_occ_nm
947 | is_infix = mk_showString_app (' ':dc_occ_nm)
952 | lab_fields == 0 = " "
955 mk_showString_app (dc_occ_nm ++ space_ocurly_maybe)
957 show_all con fs@(x:xs)
958 | is_infix = x:con:xs
962 | lab_fields > 0 = [mk_showString_app "}"]
965 con:fs ++ ccurly_maybe
967 show_thingies = show_all show_con real_show_thingies_with_labs
969 show_label l = mk_showString_app (nm ++ "=")
971 nm = occNameUserString (getOccName (fieldLabelName l))
974 mk_showString_app str = HsApp (HsVar showString_RDR)
975 (HsLit (mkHsString str))
977 prec_cons = getLRPrecs fixs_assoc dc_nm
981 [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt p))) (HsVar b)
982 | (p,b) <- zip prec_cons bs_needed ]
984 [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
987 real_show_thingies_with_labs
988 | lab_fields == 0 = intersperse (HsVar showSpace_RDR) real_show_thingies
989 | otherwise = --Assumption: no of fields == no of labelled fields
990 -- (and in same order)
992 intersperse ([mk_showString_app ","]) $ -- Using SLIT()s containing ,s spells trouble.
993 zipWithEqual "gen_Show_binds"
995 (map show_label labels)
998 (con_left_assoc, con_right_assoc) = isLRAssoc fixs_assoc dc_nm
1002 | otherwise = getFixity fixs_assoc dc_nm
1007 getLRPrecs :: Fixities -> Name -> [Integer]
1008 getLRPrecs fixs_assoc nm = [lp, rp]
1010 ( con_left_assoc, con_right_assoc) = isLRAssoc fixs_assoc nm
1011 paren_prec_limit = 9
1014 | con_left_assoc = paren_prec_limit
1015 | otherwise = paren_prec_limit + 1
1018 | con_right_assoc = paren_prec_limit
1019 | otherwise = paren_prec_limit + 1
1022 getFixity :: Fixities -> Name -> Integer
1023 getFixity fixs_assoc nm =
1024 case assocMaybe fixs_assoc nm of
1026 Just (Fixity x _) -> fromInt x + 1
1028 isLRAssoc :: Fixities -> Name -> (Bool, Bool)
1029 isLRAssoc fixs_assoc nm =
1030 case assocMaybe fixs_assoc nm of
1031 Just (Fixity _ InfixL) -> (True, False)
1032 Just (Fixity _ InfixR) -> (False, True)
1035 isInfixOccName :: String -> Bool
1036 isInfixOccName str =
1044 %************************************************************************
1046 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1048 %************************************************************************
1053 con2tag_Foo :: Foo ... -> Int#
1054 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1055 maxtag_Foo :: Int -- ditto (NB: not unboxed)
1058 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1063 = GenCon2Tag | GenTag2Con | GenMaxTag
1065 gen_tag_n_con_monobind
1066 :: (RdrName, -- (proto)Name for the thing in question
1067 TyCon, -- tycon in question
1071 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1072 | lots_of_constructors
1073 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1074 [([VarPatIn a_RDR], HsApp getTag_Expr a_Expr)]
1077 = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
1080 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1082 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
1084 = ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
1086 pat = ConPatIn var_RDR (nOfThem (argFieldCount var) WildPatIn)
1087 var_RDR = qual_orig_name var
1089 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1090 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1091 [([ConPatIn mkInt_RDR [VarPatIn a_RDR]],
1092 ExprWithTySig (HsApp tagToEnum_Expr a_Expr)
1093 (MonoTyVar (qual_orig_name tycon)))]
1095 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1096 = mk_easy_FunMonoBind (getSrcLoc tycon)
1097 rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
1099 max_tag = case (tyConDataCons tycon) of
1100 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1104 %************************************************************************
1106 \subsection{Utility bits for generating bindings}
1108 %************************************************************************
1110 @mk_easy_FunMonoBind fun pats binds expr@ generates:
1112 fun pat1 pat2 ... patN = expr where binds
1115 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
1116 multi-clause definitions; it generates:
1118 fun p1a p1b ... p1N = e1
1119 fun p2a p2b ... p2N = e2
1121 fun pMa pMb ... pMN = eM
1125 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
1126 -> [RdrNameMonoBinds] -> RdrNameHsExpr
1129 mk_easy_FunMonoBind loc fun pats binds expr
1130 = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
1132 mk_easy_Match loc pats binds expr
1133 = mk_match loc pats expr (mkbind binds)
1135 mkbind [] = EmptyBinds
1136 mkbind bs = MonoBind (foldr1 AndMonoBinds bs) [] Recursive
1137 -- The renamer expects everything in its input to be a
1138 -- "recursive" MonoBinds, and it is its job to sort things out
1141 mk_FunMonoBind :: SrcLoc -> RdrName
1142 -> [([RdrNamePat], RdrNameHsExpr)]
1145 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
1146 mk_FunMonoBind loc fun pats_and_exprs
1147 = FunMonoBind fun False{-not infix-}
1148 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
1151 mk_match loc pats expr binds
1152 = Match [] (map paren pats) Nothing
1153 (GRHSs (unguardedRHS expr loc) binds Nothing)
1155 paren p@(VarPatIn _) = p
1156 paren other_p = ParPatIn other_p
1160 mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
1163 ToDo: Better SrcLocs.
1167 RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1168 -> RdrNameHsExpr -> RdrNameHsExpr
1172 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1173 -> RdrNameHsExpr -> RdrNameHsExpr
1175 careful_compare_Case :: -- checks for primitive types...
1177 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1178 -> RdrNameHsExpr -> RdrNameHsExpr
1181 compare_Case = compare_gen_Case compare_RDR
1182 cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b
1183 -- Was: compare_gen_Case cmp_eq_RDR
1185 compare_gen_Case fun lt eq gt a b
1186 = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
1187 [mkSimpleMatch [ConPatIn ltTag_RDR []] lt Nothing mkGeneratedSrcLoc,
1188 mkSimpleMatch [ConPatIn eqTag_RDR []] eq Nothing mkGeneratedSrcLoc,
1189 mkSimpleMatch [ConPatIn gtTag_RDR []] gt Nothing mkGeneratedSrcLoc]
1192 careful_compare_Case ty lt eq gt a b
1193 = if not (isUnboxedType ty) then
1194 compare_gen_Case compare_RDR lt eq gt a b
1196 else -- we have to do something special for primitive things...
1197 HsIf (genOpApp a relevant_eq_op b)
1199 (HsIf (genOpApp a relevant_lt_op b) lt gt mkGeneratedSrcLoc)
1202 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1203 relevant_lt_op = assoc_ty_id lt_op_tbl ty
1205 assoc_ty_id tyids ty
1206 = if null res then panic "assoc_ty"
1209 res = [id | (ty',id) <- tyids, ty == ty']
1212 [(charPrimTy, eqH_Char_RDR)
1213 ,(intPrimTy, eqH_Int_RDR)
1214 ,(wordPrimTy, eqH_Word_RDR)
1215 ,(addrPrimTy, eqH_Addr_RDR)
1216 ,(floatPrimTy, eqH_Float_RDR)
1217 ,(doublePrimTy, eqH_Double_RDR)
1221 [(charPrimTy, ltH_Char_RDR)
1222 ,(intPrimTy, ltH_Int_RDR)
1223 ,(wordPrimTy, ltH_Word_RDR)
1224 ,(addrPrimTy, ltH_Addr_RDR)
1225 ,(floatPrimTy, ltH_Float_RDR)
1226 ,(doublePrimTy, ltH_Double_RDR)
1229 -----------------------------------------------------------------------
1231 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1233 and_Expr a b = genOpApp a and_RDR b
1234 append_Expr a b = genOpApp a append_RDR b
1236 -----------------------------------------------------------------------
1238 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1240 = if not (isUnboxedType ty) then
1242 else -- we have to do something special for primitive things...
1243 genOpApp a relevant_eq_op b
1245 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1249 argFieldCount :: DataCon -> Int -- Works on data and newtype constructors
1250 argFieldCount con = length (dataConRawArgTys con)
1254 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
1255 untag_Expr tycon [] expr = expr
1256 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1257 = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1258 [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) Nothing mkGeneratedSrcLoc]
1261 cmp_tags_Expr :: RdrName -- Comparison op
1262 -> RdrName -> RdrName -- Things to compare
1263 -> RdrNameHsExpr -- What to return if true
1264 -> RdrNameHsExpr -- What to return if false
1267 cmp_tags_Expr op a b true_case false_case
1268 = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case mkGeneratedSrcLoc
1271 :: RdrNameHsExpr -> RdrNameHsExpr
1273 enum_from_then_to_Expr
1274 :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1277 enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1278 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1280 showParen_Expr, readParen_Expr
1281 :: RdrNameHsExpr -> RdrNameHsExpr
1284 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1285 readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_RDR) e1) e2
1287 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1289 nested_compose_Expr [e] = parenify e
1290 nested_compose_Expr (e:es)
1291 = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1293 -- impossible_Expr is used in case RHSs that should never happen.
1294 -- We generate these to keep the desugarer from complaining that they *might* happen!
1295 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ "Urk! in TcGenDeriv")))
1297 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1298 -- method. It is currently only used by Enum.{succ,pred}
1299 illegal_Expr meth tp msg =
1300 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ (meth ++ '{':tp ++ "}: " ++ msg))))
1302 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1303 -- to include the value of a_RDR in the error string.
1304 illegal_toEnum_tag tp maxtag =
1305 HsApp (HsVar error_RDR)
1306 (HsApp (HsApp (HsVar append_RDR)
1307 (HsLit (HsString (_PK_ ("toEnum{" ++ tp ++ "}: tag (")))))
1308 (HsApp (HsApp (HsApp
1309 (HsVar showsPrec_RDR)
1314 (HsLit (HsString (_PK_ ") is outside of enumeration's range (0,"))))
1315 (HsApp (HsApp (HsApp
1316 (HsVar showsPrec_RDR)
1319 (HsLit (HsString (_PK_ ")")))))))
1321 parenify e@(HsVar _) = e
1322 parenify e = HsPar e
1324 -- genOpApp wraps brackets round the operator application, so that the
1325 -- renamer won't subsequently try to re-associate it.
1326 -- For some reason the renamer doesn't reassociate it right, and I can't
1327 -- be bothered to find out why just now.
1329 genOpApp e1 op e2 = mkOpApp e1 op e2
1333 qual_orig_name n = nameRdrName (getName n)
1334 varUnqual n = mkSrcUnqual varName n
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 b_Expr = HsVar b_RDR
1355 c_Expr = HsVar c_RDR
1356 d_Expr = HsVar d_RDR
1357 ltTag_Expr = HsVar ltTag_RDR
1358 eqTag_Expr = HsVar eqTag_RDR
1359 gtTag_Expr = HsVar gtTag_RDR
1360 false_Expr = HsVar false_RDR
1361 true_Expr = HsVar true_RDR
1363 getTag_Expr = HsVar getTag_RDR
1364 tagToEnum_Expr = HsVar tagToEnumH_RDR
1365 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1367 a_Pat = VarPatIn a_RDR
1368 b_Pat = VarPatIn b_RDR
1369 c_Pat = VarPatIn c_RDR
1370 d_Pat = VarPatIn d_RDR
1372 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1374 con2tag_RDR tycon = varUnqual (_PK_ ("con2tag_" ++ occNameString (getOccName tycon) ++ "#"))
1375 tag2con_RDR tycon = varUnqual (_PK_ ("tag2con_" ++ occNameString (getOccName tycon) ++ "#"))
1376 maxtag_RDR tycon = varUnqual (_PK_ ("maxtag_" ++ occNameString (getOccName tycon) ++ "#"))