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