d317f105fd6f10d0ddc081f471539e64eeb7a66e
[ghc.git] / ghc / compiler / typecheck / TcGenDeriv.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
3 %
4 \section[TcGenDeriv]{Generating derived instance declarations}
5
6 This module is nominally ``subordinate'' to @TcDeriv@, which is the
7 ``official'' interface to deriving-related things.
8
9 This is where we do all the grimy bindings' generation.
10
11 \begin{code}
12 #include "HsVersions.h"
13
14 module TcGenDeriv (
15         gen_Bounded_binds,
16         gen_Enum_binds,
17         gen_Eval_binds,
18         gen_Eq_binds,
19         gen_Ix_binds,
20         gen_Ord_binds,
21         gen_Read_binds,
22         gen_Show_binds,
23         gen_tag_n_con_monobind,
24
25         con2tag_RDR, tag2con_RDR, maxtag_RDR,
26
27         TagThingWanted(..)
28     ) where
29
30 IMP_Ubiq()
31 IMPORT_1_3(List(partition))
32
33 import HsSyn            ( HsBinds(..), MonoBinds(..), Match(..), GRHSsAndBinds(..),
34                           GRHS(..), HsExpr(..), HsLit(..), InPat(..), Stmt(..), DoOrListComp(..),
35                           SYN_IE(RecFlag), recursive,
36                           ArithSeqInfo, Sig, HsType, FixityDecl, Fixity, Fake )
37 import RdrHsSyn         ( RdrName(..), varQual, varUnqual, mkOpApp,
38                           SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNamePat)
39                         )
40 import BasicTypes       ( IfaceFlavour(..) )
41 import Id               ( GenId, isNullaryDataCon, dataConTag,
42                           dataConRawArgTys, fIRST_TAG,
43                           isDataCon, SYN_IE(DataCon), SYN_IE(ConTag),
44                           SYN_IE(Id) )
45 import Maybes           ( maybeToBool )
46 import Name             ( getOccString, getOccName, getSrcLoc, occNameString, modAndOcc, OccName, Name )
47
48 import PrimOp           ( PrimOp(..) )
49 import PrelInfo         -- Lots of RdrNames
50 import SrcLoc           ( mkGeneratedSrcLoc, SrcLoc )
51 import TyCon            ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon )
52 import Type             ( eqTy, isPrimType, SYN_IE(Type) )
53 import TysPrim          ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
54                           floatPrimTy, doublePrimTy
55                         )
56 import Util             ( mapAccumL, zipEqual, zipWith3Equal, nOfThem, panic, assertPanic )
57 \end{code}
58
59 %************************************************************************
60 %*                                                                      *
61 \subsection{Generating code, by derivable class}
62 %*                                                                      *
63 %************************************************************************
64
65 %************************************************************************
66 %*                                                                      *
67 \subsubsection{Generating @Eq@ instance declarations}
68 %*                                                                      *
69 %************************************************************************
70
71 Here are the heuristics for the code we generate for @Eq@:
72 \begin{itemize}
73 \item
74   Let's assume we have a data type with some (possibly zero) nullary
75   data constructors and some ordinary, non-nullary ones (the rest,
76   also possibly zero of them).  Here's an example, with both \tr{N}ullary
77   and \tr{O}rdinary data cons.
78 \begin{verbatim}
79 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
80 \end{verbatim}
81
82 \item
83   For the ordinary constructors (if any), we emit clauses to do The
84   Usual Thing, e.g.,:
85
86 \begin{verbatim}
87 (==) (O1 a1 b1)    (O1 a2 b2)    = a1 == a2 && b1 == b2
88 (==) (O2 a1)       (O2 a2)       = a1 == a2
89 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
90 \end{verbatim}
91
92   Note: if we're comparing unboxed things, e.g., if \tr{a1} and
93   \tr{a2} are \tr{Float#}s, then we have to generate
94 \begin{verbatim}
95 case (a1 `eqFloat#` a2) of
96   r -> r
97 \end{verbatim}
98   for that particular test.
99
100 \item
101   If there are any nullary constructors, we emit a catch-all clause of
102   the form:
103
104 \begin{verbatim}
105 (==) a b  = case (con2tag_Foo a) of { a# ->
106             case (con2tag_Foo b) of { b# ->
107             case (a# ==# b#)     of {
108               r -> r
109             }}}
110 \end{verbatim}
111
112   If there aren't any nullary constructors, we emit a simpler
113   catch-all:
114 \begin{verbatim}
115 (==) a b  = False
116 \end{verbatim}
117
118 \item
119   For the @(/=)@ method, we normally just use the default method.
120
121   If the type is an enumeration type, we could/may/should? generate
122   special code that calls @con2tag_Foo@, much like for @(==)@ shown
123   above.
124
125 \item
126   We thought about doing this: If we're also deriving @Ord@ for this
127   tycon, we generate:
128 \begin{verbatim}
129 instance ... Eq (Foo ...) where
130   (==) a b  = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
131   (/=) a b  = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
132 \begin{verbatim}
133   However, that requires that \tr{Ord <whatever>} was put in the context
134   for the instance decl, which it probably wasn't, so the decls
135   produced don't get through the typechecker.
136 \end{itemize}
137
138 \begin{code}
139 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
140
141 gen_Eq_binds tycon
142   = let
143         tycon_loc = getSrcLoc tycon
144         (nullary_cons, nonnullary_cons)
145            | isNewTyCon tycon = ([], tyConDataCons tycon)
146            | otherwise        = partition isNullaryDataCon (tyConDataCons tycon)
147
148         rest
149           = if (null nullary_cons) then
150                 case maybeTyConSingleCon tycon of
151                   Just _ -> []
152                   Nothing -> -- if cons don't match, then False
153                      [([a_Pat, b_Pat], false_Expr)]
154             else -- calc. and compare the tags
155                  [([a_Pat, b_Pat],
156                     untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
157                       (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR true_Expr false_Expr))]
158     in
159     mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
160             `AndMonoBinds`
161     mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
162         HsApp (HsVar not_RDR) (HsPar (mk_easy_App eq_RDR [a_RDR, b_RDR])))
163   where
164     ------------------------------------------------------------------
165     pats_etc data_con
166       = let
167             con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
168             con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
169
170             data_con_RDR = qual_orig_name data_con
171             con_arity   = length tys_needed
172             as_needed   = take con_arity as_RDRs
173             bs_needed   = take con_arity bs_RDRs
174             tys_needed  = dataConRawArgTys data_con
175         in
176         ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
177       where
178         nested_eq_expr []  [] [] = true_Expr
179         nested_eq_expr tys as bs
180           = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
181           where
182             nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
183 \end{code}
184
185 %************************************************************************
186 %*                                                                      *
187 \subsubsection{Generating @Ord@ instance declarations}
188 %*                                                                      *
189 %************************************************************************
190
191 For a derived @Ord@, we concentrate our attentions on @compare@
192 \begin{verbatim}
193 compare :: a -> a -> Ordering
194 data Ordering = LT | EQ | GT deriving ()
195 \end{verbatim}
196
197 We will use the same example data type as above:
198 \begin{verbatim}
199 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
200 \end{verbatim}
201
202 \begin{itemize}
203 \item
204   We do all the other @Ord@ methods with calls to @compare@:
205 \begin{verbatim}
206 instance ... (Ord <wurble> <wurble>) where
207     a <  b  = case (compare a b) of { LT -> True;  EQ -> False; GT -> False }
208     a <= b  = case (compare a b) of { LT -> True;  EQ -> True;  GT -> False }
209     a >= b  = case (compare a b) of { LT -> False; EQ -> True;  GT -> True  }
210     a >  b  = case (compare a b) of { LT -> False; EQ -> False; GT -> True  }
211
212     max a b = case (compare a b) of { LT -> b; EQ -> a;  GT -> a }
213     min a b = case (compare a b) of { LT -> a; EQ -> b;  GT -> b }
214
215     -- compare to come...
216 \end{verbatim}
217
218 \item
219   @compare@ always has two parts.  First, we use the compared
220   data-constructors' tags to deal with the case of different
221   constructors:
222 \begin{verbatim}
223 compare a b = case (con2tag_Foo a) of { a# ->
224               case (con2tag_Foo b) of { b# ->
225               case (a# ==# b#)     of {
226                True  -> cmp_eq a b
227                False -> case (a# <# b#) of
228                          True  -> _LT
229                          False -> _GT
230               }}}
231   where
232     cmp_eq = ... to come ...
233 \end{verbatim}
234
235 \item
236   We are only left with the ``help'' function @cmp_eq@, to deal with
237   comparing data constructors with the same tag.
238
239   For the ordinary constructors (if any), we emit the sorta-obvious
240   compare-style stuff; for our example:
241 \begin{verbatim}
242 cmp_eq (O1 a1 b1) (O1 a2 b2)
243   = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
244
245 cmp_eq (O2 a1) (O2 a2)
246   = compare a1 a2
247
248 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
249   = case (compare a1 a2) of {
250       LT -> LT;
251       GT -> GT;
252       EQ -> case compare b1 b2 of {
253               LT -> LT;
254               GT -> GT;
255               EQ -> compare c1 c2
256             }
257     }
258 \end{verbatim}
259
260   Again, we must be careful about unboxed comparisons.  For example,
261   if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
262   generate:
263 \begin{verbatim}
264 cmp_eq lt eq gt (O2 a1) (O2 a2)
265   = compareInt# a1 a2
266   -- or maybe the unfolded equivalent
267 \end{verbatim}
268
269 \item
270   For the remaining nullary constructors, we already know that the
271   tags are equal so:
272 \begin{verbatim}
273 cmp_eq _ _ = EQ
274 \end{verbatim}
275 \end{itemize}
276
277 \begin{code}
278 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
279
280 gen_Ord_binds tycon
281   = defaulted `AndMonoBinds` compare
282   where
283     tycon_loc = getSrcLoc tycon
284     --------------------------------------------------------------------
285     compare = mk_easy_FunMonoBind tycon_loc compare_RDR
286                 [a_Pat, b_Pat]
287                 [cmp_eq]
288             (if maybeToBool (maybeTyConSingleCon tycon) then
289                 cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
290              else
291                 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
292                   (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR
293                         -- True case; they are equal
294                         -- If an enumeration type we are done; else
295                         -- recursively compare their components
296                     (if isEnumerationTyCon tycon then
297                         eqTag_Expr
298                      else
299                         cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
300                     )
301                         -- False case; they aren't equal
302                         -- So we need to do a less-than comparison on the tags
303                     (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
304
305     (nullary_cons, nonnullary_cons)
306        | isNewTyCon tycon = ([], tyConDataCons tycon)
307        | otherwise        = partition isNullaryDataCon (tyConDataCons tycon)
308
309     cmp_eq
310       = mk_FunMonoBind tycon_loc cmp_eq_RDR (map pats_etc nonnullary_cons ++
311                                              [([WildPatIn, WildPatIn], default_rhs)])
312       where
313         pats_etc data_con
314           = ([con1_pat, con2_pat],
315              nested_compare_expr tys_needed as_needed bs_needed)
316           where
317             con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
318             con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
319
320             data_con_RDR = qual_orig_name data_con
321             con_arity   = length tys_needed
322             as_needed   = take con_arity as_RDRs
323             bs_needed   = take con_arity bs_RDRs
324             tys_needed  = dataConRawArgTys data_con
325
326             nested_compare_expr [ty] [a] [b]
327               = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
328
329             nested_compare_expr (ty:tys) (a:as) (b:bs)
330               = let eq_expr = nested_compare_expr tys as bs
331                 in  careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
332
333         default_rhs | null nullary_cons = impossible_Expr       -- Keep desugarer from complaining about
334                                                                 -- inexhaustive patterns
335                     | otherwise         = eqTag_Expr            -- Some nullary constructors;
336                                                                 -- Tags are equal, no args => return EQ
337     --------------------------------------------------------------------
338
339 defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
340
341 lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] (
342             compare_Case true_Expr  false_Expr false_Expr a_Expr b_Expr)
343 le = mk_easy_FunMonoBind mkGeneratedSrcLoc le_RDR [a_Pat, b_Pat] [] (
344             compare_Case true_Expr  true_Expr  false_Expr a_Expr b_Expr)
345 ge = mk_easy_FunMonoBind mkGeneratedSrcLoc ge_RDR [a_Pat, b_Pat] [] (
346             compare_Case false_Expr true_Expr  true_Expr  a_Expr b_Expr)
347 gt = mk_easy_FunMonoBind mkGeneratedSrcLoc gt_RDR [a_Pat, b_Pat] [] (
348             compare_Case false_Expr false_Expr true_Expr  a_Expr b_Expr)
349
350 max_ = mk_easy_FunMonoBind mkGeneratedSrcLoc max_RDR [a_Pat, b_Pat] [] (
351             compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
352 min_ = mk_easy_FunMonoBind mkGeneratedSrcLoc min_RDR [a_Pat, b_Pat] [] (
353             compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
354 \end{code}
355
356 %************************************************************************
357 %*                                                                      *
358 \subsubsection{Generating @Enum@ instance declarations}
359 %*                                                                      *
360 %************************************************************************
361
362 @Enum@ can only be derived for enumeration types.  For a type
363 \begin{verbatim}
364 data Foo ... = N1 | N2 | ... | Nn
365 \end{verbatim}
366
367 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
368 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
369
370 \begin{verbatim}
371 instance ... Enum (Foo ...) where
372     toEnum i = tag2con_Foo i
373
374     enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
375
376     -- or, really...
377     enumFrom a
378       = case con2tag_Foo a of
379           a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
380
381    enumFromThen a b
382      = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
383
384     -- or, really...
385     enumFromThen a b
386       = case con2tag_Foo a of { a# ->
387         case con2tag_Foo b of { b# ->
388         map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
389         }}
390 \end{verbatim}
391
392 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
393
394 \begin{code}
395 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
396
397 gen_Enum_binds tycon
398   = to_enum             `AndMonoBinds`
399     enum_from           `AndMonoBinds`
400     enum_from_then      `AndMonoBinds`
401     from_enum
402   where
403     tycon_loc = getSrcLoc tycon
404
405     to_enum
406       = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
407         mk_easy_App (tag2con_RDR tycon) [a_RDR]
408
409     enum_from
410       = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
411           untag_Expr tycon [(a_RDR, ah_RDR)] $
412           HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
413             HsPar (enum_from_to_Expr
414                     (mk_easy_App mkInt_RDR [ah_RDR])
415                     (HsVar (maxtag_RDR tycon)))
416
417     enum_from_then
418       = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
419           untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
420           HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
421             HsPar (enum_from_then_to_Expr
422                     (mk_easy_App mkInt_RDR [ah_RDR])
423                     (mk_easy_App mkInt_RDR [bh_RDR])
424                     (HsVar (maxtag_RDR tycon)))
425
426     from_enum
427       = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
428           untag_Expr tycon [(a_RDR, ah_RDR)] $
429           (mk_easy_App mkInt_RDR [ah_RDR])
430 \end{code}
431
432 %************************************************************************
433 %*                                                                      *
434 \subsubsection{Generating @Eval@ instance declarations}
435 %*                                                                      *
436 %************************************************************************
437
438 \begin{code}
439 gen_Eval_binds tycon = EmptyMonoBinds
440 \end{code}
441
442 %************************************************************************
443 %*                                                                      *
444 \subsubsection{Generating @Bounded@ instance declarations}
445 %*                                                                      *
446 %************************************************************************
447
448 \begin{code}
449 gen_Bounded_binds tycon
450   = if isEnumerationTyCon tycon then
451         min_bound_enum `AndMonoBinds` max_bound_enum
452     else
453         ASSERT(length data_cons == 1)
454         min_bound_1con `AndMonoBinds` max_bound_1con
455   where
456     data_cons = tyConDataCons tycon
457     tycon_loc = getSrcLoc tycon
458
459     ----- enum-flavored: ---------------------------
460     min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
461     max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR)
462
463     data_con_1    = head data_cons
464     data_con_N    = last data_cons
465     data_con_1_RDR = qual_orig_name data_con_1
466     data_con_N_RDR = qual_orig_name data_con_N
467
468     ----- single-constructor-flavored: -------------
469     arity          = argFieldCount data_con_1
470
471     min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
472                      mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
473     max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
474                      mk_easy_App data_con_1_RDR (nOfThem arity maxBound_RDR)
475 \end{code}
476
477 %************************************************************************
478 %*                                                                      *
479 \subsubsection{Generating @Ix@ instance declarations}
480 %*                                                                      *
481 %************************************************************************
482
483 Deriving @Ix@ is only possible for enumeration types and
484 single-constructor types.  We deal with them in turn.
485
486 For an enumeration type, e.g.,
487 \begin{verbatim}
488     data Foo ... = N1 | N2 | ... | Nn
489 \end{verbatim}
490 things go not too differently from @Enum@:
491 \begin{verbatim}
492 instance ... Ix (Foo ...) where
493     range (a, b)
494       = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
495
496     -- or, really...
497     range (a, b)
498       = case (con2tag_Foo a) of { a# ->
499         case (con2tag_Foo b) of { b# ->
500         map tag2con_Foo (enumFromTo (I# a#) (I# b#))
501         }}
502
503     index c@(a, b) d
504       = if inRange c d
505         then case (con2tag_Foo d -# con2tag_Foo a) of
506                r# -> I# r#
507         else error "Ix.Foo.index: out of range"
508
509     inRange (a, b) c
510       = let
511             p_tag = con2tag_Foo c
512         in
513         p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
514
515     -- or, really...
516     inRange (a, b) c
517       = case (con2tag_Foo a)   of { a_tag ->
518         case (con2tag_Foo b)   of { b_tag ->
519         case (con2tag_Foo c)   of { c_tag ->
520         if (c_tag >=# a_tag) then
521           c_tag <=# b_tag
522         else
523           False
524         }}}
525 \end{verbatim}
526 (modulo suitable case-ification to handle the unboxed tags)
527
528 For a single-constructor type (NB: this includes all tuples), e.g.,
529 \begin{verbatim}
530     data Foo ... = MkFoo a b Int Double c c
531 \end{verbatim}
532 we follow the scheme given in Figure~19 of the Haskell~1.2 report
533 (p.~147).
534
535 \begin{code}
536 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
537
538 gen_Ix_binds tycon
539   = if isEnumerationTyCon tycon
540     then enum_ixes
541     else single_con_ixes
542   where
543     tycon_str = getOccString tycon
544     tycon_loc = getSrcLoc tycon
545
546     --------------------------------------------------------------
547     enum_ixes = enum_range `AndMonoBinds`
548                 enum_index `AndMonoBinds` enum_inRange
549
550     enum_range
551       = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [a_Pat, b_Pat]] [] $
552           untag_Expr tycon [(a_RDR, ah_RDR)] $
553           untag_Expr tycon [(b_RDR, bh_RDR)] $
554           HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
555               HsPar (enum_from_to_Expr
556                         (mk_easy_App mkInt_RDR [ah_RDR])
557                         (mk_easy_App mkInt_RDR [bh_RDR]))
558
559     enum_index
560       = mk_easy_FunMonoBind tycon_loc index_RDR [AsPatIn c_RDR (TuplePatIn [a_Pat, b_Pat]), d_Pat] [] (
561         HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
562            untag_Expr tycon [(a_RDR, ah_RDR)] (
563            untag_Expr tycon [(d_RDR, dh_RDR)] (
564            let
565                 grhs = [OtherwiseGRHS (mk_easy_App mkInt_RDR [c_RDR]) tycon_loc]
566            in
567            HsCase
568              (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
569              [PatMatch (VarPatIn c_RDR)
570                                 (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
571              tycon_loc
572            ))
573         ) {-else-} (
574            HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
575         )
576         tycon_loc)
577
578     enum_inRange
579       = mk_easy_FunMonoBind tycon_loc inRange_RDR [TuplePatIn [a_Pat, b_Pat], c_Pat] [] (
580           untag_Expr tycon [(a_RDR, ah_RDR)] (
581           untag_Expr tycon [(b_RDR, bh_RDR)] (
582           untag_Expr tycon [(c_RDR, ch_RDR)] (
583           HsIf (genOpApp (HsVar ch_RDR) geH_RDR (HsVar ah_RDR)) (
584              (genOpApp (HsVar ch_RDR) leH_RDR (HsVar bh_RDR))
585           ) {-else-} (
586              false_Expr
587           ) tycon_loc))))
588
589     --------------------------------------------------------------
590     single_con_ixes = single_con_range `AndMonoBinds`
591                 single_con_index `AndMonoBinds` single_con_inRange
592
593     data_con
594       = case maybeTyConSingleCon tycon of -- just checking...
595           Nothing -> panic "get_Ix_binds"
596           Just dc -> if (any isPrimType (dataConRawArgTys dc)) then
597                          error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
598                      else
599                          dc
600
601     con_arity   = argFieldCount data_con
602     data_con_RDR = qual_orig_name data_con
603     con_pat  xs = ConPatIn data_con_RDR (map VarPatIn xs)
604     con_expr xs = mk_easy_App data_con_RDR xs
605
606     as_needed = take con_arity as_RDRs
607     bs_needed = take con_arity bs_RDRs
608     cs_needed = take con_arity cs_RDRs
609
610     --------------------------------------------------------------
611     single_con_range
612       = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] $
613         HsDo ListComp stmts tycon_loc
614       where
615         stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
616                 ++
617                 [ReturnStmt (con_expr cs_needed)]
618
619         mk_qual a b c = BindStmt (VarPatIn c)
620                                  (HsApp (HsVar range_RDR) (ExplicitTuple [HsVar a, HsVar b]))
621                                  tycon_loc
622
623     ----------------
624     single_con_index
625       = mk_easy_FunMonoBind tycon_loc index_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [range_size] (
626         foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
627       where
628         mk_index multiply_by (l, u, i)
629           = genOpApp (
630                 (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [HsVar l, HsVar u])) (HsVar i))
631            ) plus_RDR (
632                 genOpApp (
633                     (HsApp (HsVar rangeSize_RDR) (ExplicitTuple [HsVar l, HsVar u]))
634                 ) times_RDR multiply_by
635            )
636
637         range_size
638           = mk_easy_FunMonoBind tycon_loc rangeSize_RDR [TuplePatIn [a_Pat, b_Pat]] [] (
639                 genOpApp (
640                     (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [a_Expr, b_Expr])) b_Expr)
641                 ) plus_RDR (HsLit (HsInt 1)))
642
643     ------------------
644     single_con_inRange
645       = mk_easy_FunMonoBind tycon_loc inRange_RDR 
646                            [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed]
647                            [] (
648           foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
649       where
650         in_range a b c = HsApp (HsApp (HsVar inRange_RDR) (ExplicitTuple [HsVar a, HsVar b])) (HsVar c)
651 \end{code}
652
653 %************************************************************************
654 %*                                                                      *
655 \subsubsection{Generating @Read@ instance declarations}
656 %*                                                                      *
657 %************************************************************************
658
659 Ignoring all the infix-ery mumbo jumbo (ToDo)
660
661 \begin{code}
662 gen_Read_binds :: TyCon -> RdrNameMonoBinds
663
664 gen_Read_binds tycon
665   = reads_prec `AndMonoBinds` read_list
666   where
667     tycon_loc = getSrcLoc tycon
668     -----------------------------------------------------------------------
669     read_list = mk_easy_FunMonoBind tycon_loc readList_RDR [] []
670                   (HsApp (HsVar readList___RDR) (HsPar (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 0)))))
671     -----------------------------------------------------------------------
672     reads_prec
673       = let
674             read_con_comprehensions
675               = map read_con (tyConDataCons tycon)
676         in
677         mk_easy_FunMonoBind tycon_loc readsPrec_RDR [a_Pat, b_Pat] [] (
678               foldr1 append_Expr read_con_comprehensions
679         )
680       where
681         read_con data_con   -- note: "b" is the string being "read"
682           = let
683                 data_con_RDR = qual_orig_name data_con
684                 data_con_str= occNameString (getOccName data_con)
685                 con_arity   = argFieldCount data_con
686                 as_needed   = take con_arity as_RDRs
687                 bs_needed   = take con_arity bs_RDRs
688                 con_expr    = mk_easy_App data_con_RDR as_needed
689                 nullary_con = con_arity == 0
690
691                 con_qual
692                   = BindStmt
693                       (TuplePatIn [LitPatIn (HsString data_con_str), d_Pat])
694                       (HsApp (HsVar lex_RDR) c_Expr)
695                       tycon_loc
696
697                 field_quals = snd (mapAccumL mk_qual d_Expr (zipEqual "as_needed" as_needed bs_needed))
698                 mk_qual draw_from (con_field, str_left)
699                   = (HsVar str_left,    -- what to draw from down the line...
700                          BindStmt
701                           (TuplePatIn [VarPatIn con_field, VarPatIn str_left])
702                           (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 10))) draw_from)
703                           tycon_loc
704                     )
705
706                 result_expr = ExplicitTuple [con_expr, if null bs_needed 
707                                                        then d_Expr 
708                                                        else HsVar (last bs_needed)]
709
710                 stmts = (con_qual : field_quals) ++ [ReturnStmt result_expr]
711                 
712
713                 read_paren_arg
714                   = if nullary_con then -- must be False (parens are surely optional)
715                        false_Expr
716                     else -- parens depend on precedence...
717                        HsPar (genOpApp a_Expr gt_RDR (HsLit (HsInt 9)))
718             in
719             HsApp (
720               readParen_Expr read_paren_arg $ HsPar $
721                  HsLam (mk_easy_Match tycon_loc [c_Pat] [] $
722                         HsDo ListComp stmts tycon_loc)
723               ) (HsVar b_RDR)
724 \end{code}
725
726 %************************************************************************
727 %*                                                                      *
728 \subsubsection{Generating @Show@ instance declarations}
729 %*                                                                      *
730 %************************************************************************
731
732 Ignoring all the infix-ery mumbo jumbo (ToDo)
733
734 \begin{code}
735 gen_Show_binds :: TyCon -> RdrNameMonoBinds
736
737 gen_Show_binds tycon
738   = shows_prec `AndMonoBinds` show_list
739   where
740     tycon_loc = getSrcLoc tycon
741     -----------------------------------------------------------------------
742     show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
743                   (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 0)))))
744     -----------------------------------------------------------------------
745     shows_prec
746       = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
747       where
748         pats_etc data_con
749           = let
750                 data_con_RDR = qual_orig_name data_con
751                 con_arity   = argFieldCount data_con
752                 bs_needed   = take con_arity bs_RDRs
753                 con_pat     = ConPatIn data_con_RDR (map VarPatIn bs_needed)
754                 nullary_con = con_arity == 0
755
756                 show_con
757                   = let nm = occNameString (getOccName data_con)
758                         space_maybe = if nullary_con then _NIL_ else SLIT(" ")
759                     in
760                         HsApp (HsVar showString_RDR) (HsLit (HsString (nm _APPEND_ space_maybe)))
761
762                 show_thingies = show_con : (spacified real_show_thingies)
763
764                 real_show_thingies
765                   = [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
766                   | b <- bs_needed ]
767             in
768             if nullary_con then  -- skip the showParen junk...
769                 ASSERT(null bs_needed)
770                 ([a_Pat, con_pat], show_con)
771             else
772                 ([a_Pat, con_pat],
773                     showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt 10))))
774                                    (HsPar (nested_compose_Expr show_thingies)))
775           where
776             spacified []     = []
777             spacified [x]    = [x]
778             spacified (x:xs) = (x : (HsVar showSpace_RDR) : spacified xs)
779 \end{code}
780
781 %************************************************************************
782 %*                                                                      *
783 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
784 %*                                                                      *
785 %************************************************************************
786
787 \begin{verbatim}
788 data Foo ... = ...
789
790 con2tag_Foo :: Foo ... -> Int#
791 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
792 maxtag_Foo  :: Int              -- ditto (NB: not unboxed)
793 \end{verbatim}
794
795 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
796 fiddling around.
797
798 \begin{code}
799 data TagThingWanted
800   = GenCon2Tag | GenTag2Con | GenMaxTag
801
802 gen_tag_n_con_monobind
803     :: (RdrName,            -- (proto)Name for the thing in question
804         TyCon,              -- tycon in question
805         TagThingWanted)
806     -> RdrNameMonoBinds
807
808 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
809   = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
810   where
811     mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
812
813     mk_stuff var
814       = ASSERT(isDataCon var)
815         ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
816       where
817         pat    = ConPatIn var_RDR (nOfThem (argFieldCount var) WildPatIn)
818         var_RDR = qual_orig_name var
819
820 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
821   = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon) ++ 
822                                                              [([WildPatIn], impossible_Expr)])
823   where
824     mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
825
826     mk_stuff var
827       = ASSERT(isDataCon var)
828         ([lit_pat], HsVar var_RDR)
829       where
830         lit_pat = ConPatIn mkInt_RDR [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))]
831         var_RDR  = qual_orig_name var
832
833 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
834   = mk_easy_FunMonoBind (getSrcLoc tycon) 
835                 rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
836   where
837     max_tag =  case (tyConDataCons tycon) of
838                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
839
840 \end{code}
841
842 %************************************************************************
843 %*                                                                      *
844 \subsection{Utility bits for generating bindings}
845 %*                                                                      *
846 %************************************************************************
847
848 @mk_easy_FunMonoBind fun pats binds expr@ generates:
849 \begin{verbatim}
850     fun pat1 pat2 ... patN = expr where binds
851 \end{verbatim}
852
853 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
854 multi-clause definitions; it generates:
855 \begin{verbatim}
856     fun p1a p1b ... p1N = e1
857     fun p2a p2b ... p2N = e2
858     ...
859     fun pMa pMb ... pMN = eM
860 \end{verbatim}
861
862 \begin{code}
863 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
864                     -> [RdrNameMonoBinds] -> RdrNameHsExpr
865                     -> RdrNameMonoBinds
866
867 mk_easy_FunMonoBind loc fun pats binds expr
868   = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
869
870 mk_easy_Match loc pats binds expr
871   = mk_match loc pats expr (mkbind binds)
872   where
873     mkbind [] = EmptyBinds
874     mkbind bs = MonoBind (foldr1 AndMonoBinds bs) [] recursive
875         -- The renamer expects everything in its input to be a
876         -- "recursive" MonoBinds, and it is its job to sort things out
877         -- from there.
878
879 mk_FunMonoBind  :: SrcLoc -> RdrName
880                 -> [([RdrNamePat], RdrNameHsExpr)]
881                 -> RdrNameMonoBinds
882
883 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
884 mk_FunMonoBind loc fun pats_and_exprs
885   = FunMonoBind fun False{-not infix-}
886                 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
887                 loc
888
889 mk_match loc pats expr binds
890   = foldr PatMatch
891           (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr loc] binds))
892           (map paren pats)
893   where
894     paren p@(VarPatIn _) = p
895     paren other_p        = ParPatIn other_p
896 \end{code}
897
898 \begin{code}
899 mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
900 \end{code}
901
902 ToDo: Better SrcLocs.
903
904 \begin{code}
905 compare_Case, cmp_eq_Expr ::
906           RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
907           -> RdrNameHsExpr -> RdrNameHsExpr
908           -> RdrNameHsExpr
909 compare_gen_Case ::
910           RdrName
911           -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
912           -> RdrNameHsExpr -> RdrNameHsExpr
913           -> RdrNameHsExpr
914 careful_compare_Case :: -- checks for primitive types...
915           Type
916           -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
917           -> RdrNameHsExpr -> RdrNameHsExpr
918           -> RdrNameHsExpr
919
920 compare_Case = compare_gen_Case compare_RDR
921 cmp_eq_Expr = compare_gen_Case cmp_eq_RDR
922
923 compare_gen_Case fun lt eq gt a b
924   = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
925       [PatMatch (ConPatIn ltTag_RDR [])
926           (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS lt mkGeneratedSrcLoc] EmptyBinds)),
927
928        PatMatch (ConPatIn eqTag_RDR [])
929           (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS eq mkGeneratedSrcLoc] EmptyBinds)),
930
931        PatMatch (ConPatIn gtTag_RDR [])
932           (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS gt mkGeneratedSrcLoc] EmptyBinds))]
933        mkGeneratedSrcLoc
934
935 careful_compare_Case ty lt eq gt a b
936   = if not (isPrimType ty) then
937        compare_gen_Case compare_RDR lt eq gt a b
938
939     else -- we have to do something special for primitive things...
940        HsIf (genOpApp a relevant_eq_op b)
941             eq
942             (HsIf (genOpApp a relevant_lt_op b) lt gt mkGeneratedSrcLoc)
943             mkGeneratedSrcLoc
944   where
945     relevant_eq_op = assoc_ty_id eq_op_tbl ty
946     relevant_lt_op = assoc_ty_id lt_op_tbl ty
947
948 assoc_ty_id tyids ty 
949   = if null res then panic "assoc_ty"
950     else head res
951   where
952     res = [id | (ty',id) <- tyids, eqTy ty ty']
953
954 eq_op_tbl =
955     [(charPrimTy,       eqH_Char_RDR)
956     ,(intPrimTy,        eqH_Int_RDR)
957     ,(wordPrimTy,       eqH_Word_RDR)
958     ,(addrPrimTy,       eqH_Addr_RDR)
959     ,(floatPrimTy,      eqH_Float_RDR)
960     ,(doublePrimTy,     eqH_Double_RDR)
961     ]
962
963 lt_op_tbl =
964     [(charPrimTy,       ltH_Char_RDR)
965     ,(intPrimTy,        ltH_Int_RDR)
966     ,(wordPrimTy,       ltH_Word_RDR)
967     ,(addrPrimTy,       ltH_Addr_RDR)
968     ,(floatPrimTy,      ltH_Float_RDR)
969     ,(doublePrimTy,     ltH_Double_RDR)
970     ]
971
972 -----------------------------------------------------------------------
973
974 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
975
976 and_Expr    a b = genOpApp a and_RDR    b
977 append_Expr a b = genOpApp a append_RDR b
978
979 -----------------------------------------------------------------------
980
981 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
982 eq_Expr ty a b
983   = if not (isPrimType ty) then
984        genOpApp a eq_RDR  b
985     else -- we have to do something special for primitive things...
986        genOpApp a relevant_eq_op b
987   where
988     relevant_eq_op = assoc_ty_id eq_op_tbl ty
989 \end{code}
990
991 \begin{code}
992 argFieldCount :: Id -> Int      -- Works on data and newtype constructors
993 argFieldCount con = length (dataConRawArgTys con)
994 \end{code}
995
996 \begin{code}
997 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
998 untag_Expr tycon [] expr = expr
999 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1000   = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1001       [PatMatch (VarPatIn put_tag_here)
1002                         (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
1003       mkGeneratedSrcLoc
1004   where
1005     grhs = [OtherwiseGRHS (untag_Expr tycon more expr) mkGeneratedSrcLoc]
1006
1007 cmp_tags_Expr :: RdrName                -- Comparison op
1008              -> RdrName -> RdrName      -- Things to compare
1009              -> RdrNameHsExpr           -- What to return if true
1010              -> RdrNameHsExpr           -- What to return if false
1011              -> RdrNameHsExpr
1012
1013 cmp_tags_Expr op a b true_case false_case
1014   = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case mkGeneratedSrcLoc
1015
1016 enum_from_to_Expr
1017         :: RdrNameHsExpr -> RdrNameHsExpr
1018         -> RdrNameHsExpr
1019 enum_from_then_to_Expr
1020         :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1021         -> RdrNameHsExpr
1022
1023 enum_from_to_Expr      f   t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1024 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1025
1026 showParen_Expr, readParen_Expr
1027         :: RdrNameHsExpr -> RdrNameHsExpr
1028         -> RdrNameHsExpr
1029
1030 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1031 readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_RDR) e1) e2
1032
1033 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1034
1035 nested_compose_Expr [e] = parenify e
1036 nested_compose_Expr (e:es)
1037   = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1038
1039 -- impossible_Expr is used in case RHSs that should never happen.
1040 -- We generate these to keep the desugarer from complaining that they *might* happen!
1041 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ "Urk! in TcGenDeriv")))
1042
1043 parenify e@(HsVar _) = e
1044 parenify e           = HsPar e
1045
1046 -- genOpApp wraps brackets round the operator application, so that the
1047 -- renamer won't subsequently try to re-associate it. 
1048 -- For some reason the renamer doesn't reassociate it right, and I can't
1049 -- be bothered to find out why just now.
1050
1051 genOpApp e1 op e2 = mkOpApp e1 op e2
1052 \end{code}
1053
1054 \begin{code}
1055 qual_orig_name n = case modAndOcc n of { (m,n) -> Qual m n HiFile }
1056
1057 a_RDR           = varUnqual SLIT("a")
1058 b_RDR           = varUnqual SLIT("b")
1059 c_RDR           = varUnqual SLIT("c")
1060 d_RDR           = varUnqual SLIT("d")
1061 ah_RDR          = varUnqual SLIT("a#")
1062 bh_RDR          = varUnqual SLIT("b#")
1063 ch_RDR          = varUnqual SLIT("c#")
1064 dh_RDR          = varUnqual SLIT("d#")
1065 cmp_eq_RDR      = varUnqual SLIT("cmp_eq")
1066 rangeSize_RDR   = varUnqual SLIT("rangeSize")
1067
1068 as_RDRs         = [ varUnqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
1069 bs_RDRs         = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
1070 cs_RDRs         = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
1071
1072 a_Expr          = HsVar a_RDR
1073 b_Expr          = HsVar b_RDR
1074 c_Expr          = HsVar c_RDR
1075 d_Expr          = HsVar d_RDR
1076 ltTag_Expr      = HsVar ltTag_RDR
1077 eqTag_Expr      = HsVar eqTag_RDR
1078 gtTag_Expr      = HsVar gtTag_RDR
1079 false_Expr      = HsVar false_RDR
1080 true_Expr       = HsVar true_RDR
1081
1082 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1083
1084 a_Pat           = VarPatIn a_RDR
1085 b_Pat           = VarPatIn b_RDR
1086 c_Pat           = VarPatIn c_RDR
1087 d_Pat           = VarPatIn d_RDR
1088
1089 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1090
1091 con2tag_RDR tycon = varUnqual (SLIT("con2tag_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
1092 tag2con_RDR tycon = varUnqual (SLIT("tag2con_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
1093 maxtag_RDR tycon  = varUnqual (SLIT("maxtag_")  _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
1094 \end{code}