[project @ 2002-04-29 14:03:38 by simonmar]
[ghc-hetmet.git] / ghc / compiler / typecheck / TcGenDeriv.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
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 module TcGenDeriv (
13         gen_Bounded_binds,
14         gen_Enum_binds,
15         gen_Eq_binds,
16         gen_Ix_binds,
17         gen_Ord_binds,
18         gen_Read_binds,
19         gen_Show_binds,
20         gen_tag_n_con_monobind,
21
22         con2tag_RDR, tag2con_RDR, maxtag_RDR,
23
24         TagThingWanted(..)
25     ) where
26
27 #include "HsVersions.h"
28
29 import HsSyn            ( InPat(..), HsExpr(..), MonoBinds(..),
30                           Match(..), GRHSs(..), Stmt(..), HsLit(..),
31                           HsBinds(..), HsType(..), HsDoContext(..),
32                           unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList, placeHolderType
33                         )
34 import RdrHsSyn         ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
35 import RdrName          ( RdrName, mkUnqual )
36 import BasicTypes       ( RecFlag(..), Fixity(..), FixityDirection(..)
37                         , maxPrecedence
38                         , Boxity(..)
39                         )
40 import FieldLabel       ( FieldLabel, fieldLabelName )
41 import DataCon          ( isNullaryDataCon, dataConTag,
42                           dataConOrigArgTys, dataConSourceArity, fIRST_TAG,
43                           DataCon, 
44                           dataConFieldLabels )
45 import Name             ( getOccString, getOccName, getSrcLoc, occNameString, 
46                           occNameUserString, nameRdrName, varName,
47                           Name, NamedThing(..), 
48                           isDataSymOcc, isSymOcc
49                         )
50
51 import HscTypes         ( FixityEnv, lookupFixity )
52 import PrelInfo         -- Lots of RdrNames
53 import SrcLoc           ( generatedSrcLoc, SrcLoc )
54 import TyCon            ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
55                           maybeTyConSingleCon, tyConFamilySize
56                         )
57 import TcType           ( isUnLiftedType, tcEqType, Type )
58 import TysPrim          ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
59                           floatPrimTy, doublePrimTy
60                         )
61 import Util             ( mapAccumL, zipEqual, zipWithEqual, isSingleton,
62                           zipWith3Equal, nOfThem )
63 import Panic            ( panic, assertPanic )
64 import Maybes           ( maybeToBool )
65 import Char             ( ord )
66 import Constants
67 import List             ( partition, intersperse )
68 import FastString
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 unlifted 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
151 deriveEq :: RdrName                             -- Class
152          -> RdrName                             -- Type constructor
153          -> [ (RdrName, [RdrType]) ]    -- Constructors
154          -> (RdrContext,                -- Context for the inst decl
155              [RdrBind],                 -- Binds in the inst decl
156              [RdrBind])                 -- Extra value bindings outside
157
158 deriveEq clas tycon constrs 
159   = (context, [eq_bind, ne_bind], [])
160   where
161     context = [(clas, [ty]) | (_, tys) <- constrs, ty <- tys]
162
163     ne_bind = mkBind 
164     (nullary_cons, non_nullary_cons) = partition is_nullary constrs
165     is_nullary (_, args) = null args
166
167 \begin{code}
168 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
169
170 gen_Eq_binds tycon
171   = let
172         tycon_loc = getSrcLoc tycon
173         (nullary_cons, nonnullary_cons)
174            | isNewTyCon tycon = ([], tyConDataCons tycon)
175            | otherwise        = partition isNullaryDataCon (tyConDataCons tycon)
176
177         rest
178           = if (null nullary_cons) then
179                 case maybeTyConSingleCon tycon of
180                   Just _ -> []
181                   Nothing -> -- if cons don't match, then False
182                      [([wildPat, wildPat], false_Expr)]
183             else -- calc. and compare the tags
184                  [([a_Pat, b_Pat],
185                     untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
186                                (genOpApp (HsVar ah_RDR) eqH_Int_RDR (HsVar bh_RDR)))]
187     in
188     mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
189             `AndMonoBinds`
190     mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
191         HsApp (HsVar not_RDR) (HsPar (mkHsVarApps eq_RDR [a_RDR, b_RDR])))
192   where
193     ------------------------------------------------------------------
194     pats_etc data_con
195       = let
196             con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
197             con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
198
199             data_con_RDR = qual_orig_name data_con
200             con_arity   = length tys_needed
201             as_needed   = take con_arity as_RDRs
202             bs_needed   = take con_arity bs_RDRs
203             tys_needed  = dataConOrigArgTys data_con
204         in
205         ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
206       where
207         nested_eq_expr []  [] [] = true_Expr
208         nested_eq_expr tys as bs
209           = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
210           where
211             nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
212 \end{code}
213
214 %************************************************************************
215 %*                                                                      *
216 \subsubsection{Generating @Ord@ instance declarations}
217 %*                                                                      *
218 %************************************************************************
219
220 For a derived @Ord@, we concentrate our attentions on @compare@
221 \begin{verbatim}
222 compare :: a -> a -> Ordering
223 data Ordering = LT | EQ | GT deriving ()
224 \end{verbatim}
225
226 We will use the same example data type as above:
227 \begin{verbatim}
228 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
229 \end{verbatim}
230
231 \begin{itemize}
232 \item
233   We do all the other @Ord@ methods with calls to @compare@:
234 \begin{verbatim}
235 instance ... (Ord <wurble> <wurble>) where
236     a <  b  = case (compare a b) of { LT -> True;  EQ -> False; GT -> False }
237     a <= b  = case (compare a b) of { LT -> True;  EQ -> True;  GT -> False }
238     a >= b  = case (compare a b) of { LT -> False; EQ -> True;  GT -> True  }
239     a >  b  = case (compare a b) of { LT -> False; EQ -> False; GT -> True  }
240
241     max a b = case (compare a b) of { LT -> b; EQ -> a;  GT -> a }
242     min a b = case (compare a b) of { LT -> a; EQ -> b;  GT -> b }
243
244     -- compare to come...
245 \end{verbatim}
246
247 \item
248   @compare@ always has two parts.  First, we use the compared
249   data-constructors' tags to deal with the case of different
250   constructors:
251 \begin{verbatim}
252 compare a b = case (con2tag_Foo a) of { a# ->
253               case (con2tag_Foo b) of { b# ->
254               case (a# ==# b#)     of {
255                True  -> cmp_eq a b
256                False -> case (a# <# b#) of
257                          True  -> _LT
258                          False -> _GT
259               }}}
260   where
261     cmp_eq = ... to come ...
262 \end{verbatim}
263
264 \item
265   We are only left with the ``help'' function @cmp_eq@, to deal with
266   comparing data constructors with the same tag.
267
268   For the ordinary constructors (if any), we emit the sorta-obvious
269   compare-style stuff; for our example:
270 \begin{verbatim}
271 cmp_eq (O1 a1 b1) (O1 a2 b2)
272   = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
273
274 cmp_eq (O2 a1) (O2 a2)
275   = compare a1 a2
276
277 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
278   = case (compare a1 a2) of {
279       LT -> LT;
280       GT -> GT;
281       EQ -> case compare b1 b2 of {
282               LT -> LT;
283               GT -> GT;
284               EQ -> compare c1 c2
285             }
286     }
287 \end{verbatim}
288
289   Again, we must be careful about unlifted comparisons.  For example,
290   if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
291   generate:
292
293 \begin{verbatim}
294 cmp_eq lt eq gt (O2 a1) (O2 a2)
295   = compareInt# a1 a2
296   -- or maybe the unfolded equivalent
297 \end{verbatim}
298
299 \item
300   For the remaining nullary constructors, we already know that the
301   tags are equal so:
302 \begin{verbatim}
303 cmp_eq _ _ = EQ
304 \end{verbatim}
305 \end{itemize}
306
307 If there is only one constructor in the Data Type we don't need the WildCard Pattern. 
308 JJQC-30-Nov-1997
309
310 \begin{code}
311 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
312
313 gen_Ord_binds tycon
314   = compare     -- `AndMonoBinds` compare       
315                 -- The default declaration in PrelBase handles this
316   where
317     tycon_loc = getSrcLoc tycon
318     --------------------------------------------------------------------
319     compare = mk_easy_FunMonoBind tycon_loc compare_RDR
320                 [a_Pat, b_Pat]
321                 [cmp_eq]
322             (if maybeToBool (maybeTyConSingleCon tycon) then
323
324 --              cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
325 -- Weird.  Was: case (cmp a b) of { LT -> LT; EQ -> EQ; GT -> GT }
326
327                 cmp_eq_Expr a_Expr b_Expr
328              else
329                 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
330                   (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR
331                         -- True case; they are equal
332                         -- If an enumeration type we are done; else
333                         -- recursively compare their components
334                     (if isEnumerationTyCon tycon then
335                         eqTag_Expr
336                      else
337 --                      cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
338 -- Ditto
339                         cmp_eq_Expr a_Expr b_Expr
340                     )
341                         -- False case; they aren't equal
342                         -- So we need to do a less-than comparison on the tags
343                     (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
344
345     tycon_data_cons = tyConDataCons tycon
346     (nullary_cons, nonnullary_cons)
347        | isNewTyCon tycon = ([], tyConDataCons tycon)
348        | otherwise        = partition isNullaryDataCon tycon_data_cons
349
350     cmp_eq =
351        mk_FunMonoBind tycon_loc 
352                       cmp_eq_RDR 
353                       (if null nonnullary_cons && isSingleton nullary_cons then
354                            -- catch this specially to avoid warnings
355                            -- about overlapping patterns from the desugarer.
356                           let 
357                            data_con     = head nullary_cons
358                            data_con_RDR = qual_orig_name data_con
359                            pat          = ConPatIn data_con_RDR []
360                           in
361                           [([pat,pat], eqTag_Expr)]
362                        else
363                           map pats_etc nonnullary_cons ++
364                           -- leave out wildcards to silence desugarer.
365                           (if isSingleton tycon_data_cons then
366                               []
367                            else
368                               [([WildPatIn, WildPatIn], default_rhs)]))
369       where
370         pats_etc data_con
371           = ([con1_pat, con2_pat],
372              nested_compare_expr tys_needed as_needed bs_needed)
373           where
374             con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
375             con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
376
377             data_con_RDR = qual_orig_name data_con
378             con_arity   = length tys_needed
379             as_needed   = take con_arity as_RDRs
380             bs_needed   = take con_arity bs_RDRs
381             tys_needed  = dataConOrigArgTys data_con
382
383             nested_compare_expr [ty] [a] [b]
384               = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
385
386             nested_compare_expr (ty:tys) (a:as) (b:bs)
387               = let eq_expr = nested_compare_expr tys as bs
388                 in  careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
389
390         default_rhs | null nullary_cons = impossible_Expr       -- Keep desugarer from complaining about
391                                                                 -- inexhaustive patterns
392                     | otherwise         = eqTag_Expr            -- Some nullary constructors;
393                                                                 -- Tags are equal, no args => return EQ
394 \end{code}
395
396 %************************************************************************
397 %*                                                                      *
398 \subsubsection{Generating @Enum@ instance declarations}
399 %*                                                                      *
400 %************************************************************************
401
402 @Enum@ can only be derived for enumeration types.  For a type
403 \begin{verbatim}
404 data Foo ... = N1 | N2 | ... | Nn
405 \end{verbatim}
406
407 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
408 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
409
410 \begin{verbatim}
411 instance ... Enum (Foo ...) where
412     succ x   = toEnum (1 + fromEnum x)
413     pred x   = toEnum (fromEnum x - 1)
414
415     toEnum i = tag2con_Foo i
416
417     enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
418
419     -- or, really...
420     enumFrom a
421       = case con2tag_Foo a of
422           a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
423
424    enumFromThen a b
425      = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
426
427     -- or, really...
428     enumFromThen a b
429       = case con2tag_Foo a of { a# ->
430         case con2tag_Foo b of { b# ->
431         map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
432         }}
433 \end{verbatim}
434
435 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
436
437 \begin{code}
438 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
439
440 gen_Enum_binds tycon
441   = succ_enum           `AndMonoBinds`
442     pred_enum           `AndMonoBinds`
443     to_enum             `AndMonoBinds`
444     enum_from           `AndMonoBinds`
445     enum_from_then      `AndMonoBinds`
446     from_enum
447   where
448     tycon_loc = getSrcLoc tycon
449     occ_nm    = getOccString tycon
450
451     succ_enum
452       = mk_easy_FunMonoBind tycon_loc succ_RDR [a_Pat] [] $
453         untag_Expr tycon [(a_RDR, ah_RDR)] $
454         HsIf (mkHsApps eq_RDR [HsVar (maxtag_RDR tycon),
455                                mkHsVarApps mkInt_RDR [ah_RDR]])
456              (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
457              (HsApp (HsVar (tag2con_RDR tycon))
458                     (mkHsApps plus_RDR [mkHsVarApps mkInt_RDR [ah_RDR],
459                                         mkHsIntLit 1]))
460              tycon_loc
461                     
462     pred_enum
463       = mk_easy_FunMonoBind tycon_loc pred_RDR [a_Pat] [] $
464         untag_Expr tycon [(a_RDR, ah_RDR)] $
465         HsIf (mkHsApps eq_RDR [mkHsIntLit 0,
466                                mkHsVarApps mkInt_RDR [ah_RDR]])
467              (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
468              (HsApp (HsVar (tag2con_RDR tycon))
469                            (mkHsApps plus_RDR [mkHsVarApps mkInt_RDR [ah_RDR],
470                                                HsLit (HsInt (-1))]))
471              tycon_loc
472
473     to_enum
474       = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
475         HsIf (mkHsApps and_RDR
476                 [mkHsApps ge_RDR [HsVar a_RDR, mkHsIntLit 0],
477                  mkHsApps le_RDR [HsVar a_RDR, HsVar (maxtag_RDR tycon)]])
478              (mkHsVarApps (tag2con_RDR tycon) [a_RDR])
479              (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
480              tycon_loc
481
482     enum_from
483       = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
484           untag_Expr tycon [(a_RDR, ah_RDR)] $
485           mkHsApps map_RDR 
486                 [HsVar (tag2con_RDR tycon),
487                  HsPar (enum_from_to_Expr
488                             (mkHsVarApps mkInt_RDR [ah_RDR])
489                             (HsVar (maxtag_RDR tycon)))]
490
491     enum_from_then
492       = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
493           untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
494           HsApp (mkHsVarApps map_RDR [tag2con_RDR tycon]) $
495             HsPar (enum_from_then_to_Expr
496                     (mkHsVarApps mkInt_RDR [ah_RDR])
497                     (mkHsVarApps mkInt_RDR [bh_RDR])
498                     (HsIf  (mkHsApps gt_RDR [mkHsVarApps mkInt_RDR [ah_RDR],
499                                              mkHsVarApps mkInt_RDR [bh_RDR]])
500                            (mkHsIntLit 0)
501                            (HsVar (maxtag_RDR tycon))
502                            tycon_loc))
503
504     from_enum
505       = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
506           untag_Expr tycon [(a_RDR, ah_RDR)] $
507           (mkHsVarApps mkInt_RDR [ah_RDR])
508 \end{code}
509
510 %************************************************************************
511 %*                                                                      *
512 \subsubsection{Generating @Bounded@ instance declarations}
513 %*                                                                      *
514 %************************************************************************
515
516 \begin{code}
517 gen_Bounded_binds tycon
518   = if isEnumerationTyCon tycon then
519         min_bound_enum `AndMonoBinds` max_bound_enum
520     else
521         ASSERT(isSingleton data_cons)
522         min_bound_1con `AndMonoBinds` max_bound_1con
523   where
524     data_cons = tyConDataCons tycon
525     tycon_loc = getSrcLoc tycon
526
527     ----- enum-flavored: ---------------------------
528     min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
529     max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR)
530
531     data_con_1    = head data_cons
532     data_con_N    = last data_cons
533     data_con_1_RDR = qual_orig_name data_con_1
534     data_con_N_RDR = qual_orig_name data_con_N
535
536     ----- single-constructor-flavored: -------------
537     arity          = dataConSourceArity data_con_1
538
539     min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
540                      mkHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
541     max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
542                      mkHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
543 \end{code}
544
545 %************************************************************************
546 %*                                                                      *
547 \subsubsection{Generating @Ix@ instance declarations}
548 %*                                                                      *
549 %************************************************************************
550
551 Deriving @Ix@ is only possible for enumeration types and
552 single-constructor types.  We deal with them in turn.
553
554 For an enumeration type, e.g.,
555 \begin{verbatim}
556     data Foo ... = N1 | N2 | ... | Nn
557 \end{verbatim}
558 things go not too differently from @Enum@:
559 \begin{verbatim}
560 instance ... Ix (Foo ...) where
561     range (a, b)
562       = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
563
564     -- or, really...
565     range (a, b)
566       = case (con2tag_Foo a) of { a# ->
567         case (con2tag_Foo b) of { b# ->
568         map tag2con_Foo (enumFromTo (I# a#) (I# b#))
569         }}
570
571     index c@(a, b) d
572       = if inRange c d
573         then case (con2tag_Foo d -# con2tag_Foo a) of
574                r# -> I# r#
575         else error "Ix.Foo.index: out of range"
576
577     inRange (a, b) c
578       = let
579             p_tag = con2tag_Foo c
580         in
581         p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
582
583     -- or, really...
584     inRange (a, b) c
585       = case (con2tag_Foo a)   of { a_tag ->
586         case (con2tag_Foo b)   of { b_tag ->
587         case (con2tag_Foo c)   of { c_tag ->
588         if (c_tag >=# a_tag) then
589           c_tag <=# b_tag
590         else
591           False
592         }}}
593 \end{verbatim}
594 (modulo suitable case-ification to handle the unlifted tags)
595
596 For a single-constructor type (NB: this includes all tuples), e.g.,
597 \begin{verbatim}
598     data Foo ... = MkFoo a b Int Double c c
599 \end{verbatim}
600 we follow the scheme given in Figure~19 of the Haskell~1.2 report
601 (p.~147).
602
603 \begin{code}
604 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
605
606 gen_Ix_binds tycon
607   = if isEnumerationTyCon tycon
608     then enum_ixes
609     else single_con_ixes
610   where
611     tycon_str = getOccString tycon
612     tycon_loc = getSrcLoc tycon
613
614     --------------------------------------------------------------
615     enum_ixes = enum_range `AndMonoBinds`
616                 enum_index `AndMonoBinds` enum_inRange
617
618     enum_range
619       = mk_easy_FunMonoBind tycon_loc range_RDR 
620                 [TuplePatIn [a_Pat, b_Pat] Boxed] [] $
621           untag_Expr tycon [(a_RDR, ah_RDR)] $
622           untag_Expr tycon [(b_RDR, bh_RDR)] $
623           HsApp (mkHsVarApps map_RDR [tag2con_RDR tycon]) $
624               HsPar (enum_from_to_Expr
625                         (mkHsVarApps mkInt_RDR [ah_RDR])
626                         (mkHsVarApps mkInt_RDR [bh_RDR]))
627
628     enum_index
629       = mk_easy_FunMonoBind tycon_loc index_RDR 
630                 [AsPatIn c_RDR (TuplePatIn [a_Pat, wildPat] Boxed), 
631                                 d_Pat] [] (
632         HsIf (HsPar (mkHsVarApps inRange_RDR [c_RDR, d_RDR])) (
633            untag_Expr tycon [(a_RDR, ah_RDR)] (
634            untag_Expr tycon [(d_RDR, dh_RDR)] (
635            let
636                 rhs = mkHsVarApps mkInt_RDR [c_RDR]
637            in
638            HsCase
639              (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
640              [mkSimpleMatch [VarPatIn c_RDR] rhs placeHolderType tycon_loc]
641              tycon_loc
642            ))
643         ) {-else-} (
644            HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString ("Ix."++tycon_str++".index: out of range\n"))))
645         )
646         tycon_loc)
647
648     enum_inRange
649       = mk_easy_FunMonoBind tycon_loc inRange_RDR 
650           [TuplePatIn [a_Pat, b_Pat] Boxed, c_Pat] [] (
651           untag_Expr tycon [(a_RDR, ah_RDR)] (
652           untag_Expr tycon [(b_RDR, bh_RDR)] (
653           untag_Expr tycon [(c_RDR, ch_RDR)] (
654           HsIf (genOpApp (HsVar ch_RDR) geH_RDR (HsVar ah_RDR)) (
655              (genOpApp (HsVar ch_RDR) leH_RDR (HsVar bh_RDR))
656           ) {-else-} (
657              false_Expr
658           ) tycon_loc))))
659
660     --------------------------------------------------------------
661     single_con_ixes 
662       = single_con_range `AndMonoBinds`
663         single_con_index `AndMonoBinds`
664         single_con_inRange
665
666     data_con
667       = case maybeTyConSingleCon tycon of -- just checking...
668           Nothing -> panic "get_Ix_binds"
669           Just dc -> if (any isUnLiftedType (dataConOrigArgTys dc)) then
670                          error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
671                      else
672                          dc
673
674     con_arity    = dataConSourceArity data_con
675     data_con_RDR = qual_orig_name data_con
676
677     as_needed = take con_arity as_RDRs
678     bs_needed = take con_arity bs_RDRs
679     cs_needed = take con_arity cs_RDRs
680
681     con_pat  xs  = ConPatIn data_con_RDR (map VarPatIn xs)
682     con_expr     = mkHsVarApps data_con_RDR cs_needed
683
684     --------------------------------------------------------------
685     single_con_range
686       = mk_easy_FunMonoBind tycon_loc range_RDR 
687           [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed] [] $
688         HsDo ListComp stmts tycon_loc
689       where
690         stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
691                 ++
692                 [ResultStmt con_expr tycon_loc]
693
694         mk_qual a b c = BindStmt (VarPatIn c)
695                                  (HsApp (HsVar range_RDR) 
696                                         (ExplicitTuple [HsVar a, HsVar b] Boxed))
697                                  tycon_loc
698
699     ----------------
700     single_con_index
701       = mk_easy_FunMonoBind tycon_loc index_RDR 
702                 [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed, 
703                  con_pat cs_needed] [range_size] (
704         foldl mk_index (mkHsIntLit 0) (zip3 as_needed bs_needed cs_needed))
705       where
706         mk_index multiply_by (l, u, i)
707           = genOpApp (
708                (mkHsApps index_RDR [ExplicitTuple [HsVar l, HsVar u] Boxed,  
709                                     HsVar i])
710            ) plus_RDR (
711                 genOpApp (
712                     (HsApp (HsVar rangeSize_RDR) 
713                            (ExplicitTuple [HsVar l, HsVar u] Boxed))
714                 ) times_RDR multiply_by
715            )
716
717         range_size
718           = mk_easy_FunMonoBind tycon_loc rangeSize_RDR 
719                         [TuplePatIn [a_Pat, b_Pat] Boxed] [] (
720                 genOpApp (
721                     (mkHsApps index_RDR [ExplicitTuple [a_Expr, b_Expr] Boxed,
722                                          b_Expr])
723                 ) plus_RDR (mkHsIntLit 1))
724
725     ------------------
726     single_con_inRange
727       = mk_easy_FunMonoBind tycon_loc inRange_RDR 
728                 [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed, 
729                  con_pat cs_needed]
730                            [] (
731           foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
732       where
733         in_range a b c = mkHsApps inRange_RDR [ExplicitTuple [HsVar a, HsVar b] Boxed,
734                                                HsVar c]
735 \end{code}
736
737 %************************************************************************
738 %*                                                                      *
739 \subsubsection{Generating @Read@ instance declarations}
740 %*                                                                      *
741 %************************************************************************
742
743 Example
744
745   infix 4 %%
746   data T = Int %% Int
747          | T1 { f1 :: Int }
748          | T2 Int
749
750
751 instance Read T where
752   readPrec =
753     block
754     ( prec 4 (
755         do x           <- ReadP.step Read.readPrec
756            Symbol "%%" <- Lex.lex
757            y           <- ReadP.step Read.readPrec
758            return (x %% y))
759       +++
760       prec appPrec (
761         do Ident "T1" <- Lex.lex
762            Single '{' <- Lex.lex
763            Ident "f1" <- Lex.lex
764            Single '=' <- Lex.lex
765            x          <- ReadP.reset Read.readPrec
766            Single '}' <- Lex.lex
767            return (T1 { f1 = x }))
768       +++
769       prec appPrec (
770         do Ident "T2" <- Lex.lexP
771            x          <- ReadP.step Read.readPrec
772            return (T2 x))
773     )
774
775   readListPrec = readListPrecDefault
776   readList     = readListDefault
777
778
779 \begin{code}
780 gen_Read_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
781
782 gen_Read_binds get_fixity tycon
783   = read_prec `AndMonoBinds` default_binds
784   where
785     -----------------------------------------------------------------------
786     default_binds 
787         = mk_easy_FunMonoBind loc readList_RDR     [] [] (HsVar readListDefault_RDR)
788                 `AndMonoBinds`
789           mk_easy_FunMonoBind loc readListPrec_RDR [] [] (HsVar readListPrecDefault_RDR)
790     -----------------------------------------------------------------------
791
792     loc       = getSrcLoc tycon
793     data_cons = tyConDataCons tycon
794     (nullary_cons, non_nullary_cons) = partition isNullaryDataCon data_cons
795     
796     read_prec = mk_easy_FunMonoBind loc readPrec_RDR [] [] 
797                                     (HsApp (HsVar parens_RDR) read_cons)
798
799     read_cons             = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
800     read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
801     
802     read_nullary_cons 
803       = case nullary_cons of
804             []    -> []
805             [con] -> [HsDo DoExpr [BindStmt (ident_pat (data_con_str con)) lex loc,
806                       result_stmt con []] loc]
807             _     -> [HsApp (HsVar choose_RDR) 
808                             (ExplicitList placeHolderType (map mk_pair nullary_cons))]
809     
810     mk_pair con = ExplicitTuple [HsLit (data_con_str con),
811                                  HsApp (HsVar returnM_RDR) (HsVar (qual_orig_name con))]
812                                 Boxed
813     
814     read_non_nullary_con data_con
815       = mkHsApps prec_RDR [mkHsIntLit prec, HsDo DoExpr stmts loc]
816       where
817         stmts | is_infix          = infix_stmts
818               | length labels > 0 = lbl_stmts
819               | otherwise         = prefix_stmts
820      
821         prefix_stmts            -- T a b c
822           = [BindStmt (ident_pat (data_con_str data_con)) lex loc]
823             ++ map read_arg as_needed
824             ++ [result_stmt data_con as_needed]
825          
826         infix_stmts             -- a %% b
827           = [read_arg a1, 
828              BindStmt (symbol_pat (data_con_str data_con)) lex loc,
829              read_arg a2,
830              result_stmt data_con [a1,a2]]
831      
832         lbl_stmts               -- T { f1 = a, f2 = b }
833           = [BindStmt (ident_pat (data_con_str data_con)) lex loc,
834              read_punc '{']
835             ++ concat (intersperse [read_punc ','] field_stmts)
836             ++ [read_punc '}', result_stmt data_con as_needed]
837      
838         field_stmts  = zipWithEqual "lbl_stmts" read_field labels as_needed
839      
840         con_arity    = dataConSourceArity data_con
841         nullary_con  = con_arity == 0
842         labels       = dataConFieldLabels data_con
843         lab_fields   = length labels
844         dc_nm   = getName data_con
845         is_infix     = isDataSymOcc (getOccName dc_nm)
846         as_needed    = take con_arity as_RDRs
847         (a1:a2:_)    = as_needed
848      
849         prec | not is_infix  = appPrecedence
850              | otherwise     = getPrecedence get_fixity dc_nm
851
852     ------------------------------------------------------------------------
853     --          Helpers
854     ------------------------------------------------------------------------
855     mk_alt e1 e2     = genOpApp e1 alt_RDR e2
856     result_stmt c as = ResultStmt (HsApp (HsVar returnM_RDR) (con_app c as)) loc
857     con_app c as     = mkHsVarApps (qual_orig_name c) as
858     
859     lex          = HsVar lexP_RDR
860     single_pat c = ConPatIn single_RDR [LitPatIn (mkHsChar c)]    -- Single 'x'
861     ident_pat s  = ConPatIn ident_RDR [LitPatIn s]                -- Ident "foo"
862     symbol_pat s = ConPatIn symbol_RDR [LitPatIn s]               -- Symbol ">>"
863     
864     lbl_str :: FieldLabel -> HsLit
865     lbl_str      lbl = mkHsString (occNameUserString (getOccName (fieldLabelName lbl)))
866     data_con_str con = mkHsString (occNameUserString (getOccName con))
867     
868     read_punc c = BindStmt (single_pat c) lex loc
869     read_arg a  = BindStmt (VarPatIn a) (mkHsVarApps step_RDR [readPrec_RDR]) loc
870     
871     read_field lbl a = [BindStmt (ident_pat (lbl_str lbl)) lex loc,
872                         read_punc '=',
873                         BindStmt (VarPatIn a) (mkHsVarApps reset_RDR [readPrec_RDR]) loc]
874 \end{code}
875
876
877 %************************************************************************
878 %*                                                                      *
879 \subsubsection{Generating @Show@ instance declarations}
880 %*                                                                      *
881 %************************************************************************
882
883 \begin{code}
884 gen_Show_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
885
886 gen_Show_binds get_fixity tycon
887   = shows_prec `AndMonoBinds` show_list
888   where
889     tycon_loc = getSrcLoc tycon
890     -----------------------------------------------------------------------
891     show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
892                   (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (mkHsIntLit 0))))
893     -----------------------------------------------------------------------
894     shows_prec = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
895       where
896         pats_etc data_con
897           | nullary_con =  -- skip the showParen junk...
898              ASSERT(null bs_needed)
899              ([wildPat, con_pat], show_con)
900           | otherwise   =
901              ([a_Pat, con_pat],
902                   showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt paren_prec_limit))))
903                                  (HsPar (nested_compose_Expr show_thingies)))
904             where
905              data_con_RDR = qual_orig_name data_con
906              con_arity    = dataConSourceArity data_con
907              bs_needed    = take con_arity bs_RDRs
908              con_pat      = ConPatIn data_con_RDR (map VarPatIn bs_needed)
909              nullary_con  = con_arity == 0
910              labels       = dataConFieldLabels data_con
911              lab_fields   = length labels
912
913              dc_nm          = getName data_con
914              dc_occ_nm      = getOccName data_con
915              dc_occ_nm_str  = occNameUserString dc_occ_nm
916
917              is_infix     = isDataSymOcc dc_occ_nm
918
919
920              show_con
921                | is_infix  = mk_showString_app (' ':dc_occ_nm_str)
922                | otherwise = mk_showString_app (dc_occ_nm_str ++ space_ocurly_maybe)
923                  where
924                   space_ocurly_maybe
925                     | nullary_con     = ""
926                     | lab_fields == 0 = " "
927                     | otherwise       = "{"
928                  
929
930              show_all con fs@(x:xs)
931                 | is_infix  = x:con:xs
932                 | otherwise = 
933                   let
934                     ccurly_maybe 
935                       | lab_fields > 0  = [mk_showString_app "}"]
936                       | otherwise       = []
937                   in
938                   con:fs ++ ccurly_maybe
939
940              show_thingies = show_all show_con real_show_thingies_with_labs
941                 
942              show_label l = mk_showString_app (the_name ++ "=")
943                  where
944                    occ_nm   = getOccName (fieldLabelName l)
945                     -- legal, but rare.
946                    is_op    = isSymOcc occ_nm
947                    the_name 
948                      | is_op     = '(':nm ++ ")"
949                      | otherwise = nm
950
951                    nm       = occNameUserString occ_nm
952                 
953
954              mk_showString_app str = HsApp (HsVar showString_RDR)
955                                            (HsLit (mkHsString str))
956
957              prec_cons = getLRPrecs is_infix get_fixity dc_nm
958
959              real_show_thingies
960                 | is_infix  = 
961                      [ mkHsApps showsPrec_RDR [HsLit (HsInt p), HsVar b]
962                      | (p,b) <- zip prec_cons bs_needed ]
963                 | otherwise =
964                      [ mkHsApps showsPrec_RDR [mkHsIntLit 10, HsVar b]
965                      | b <- bs_needed ]
966
967              real_show_thingies_with_labs
968                 | lab_fields == 0 = intersperse (HsVar showSpace_RDR) real_show_thingies
969                 | otherwise       = --Assumption: no of fields == no of labelled fields 
970                                      --            (and in same order)
971                     concat $
972                     intersperse ([mk_showString_app ","]) $ -- Using SLIT()s containing ,s spells trouble.
973                     zipWithEqual "gen_Show_binds"
974                                  (\ a b -> [a,b])
975                                  (map show_label labels) 
976                                  real_show_thingies
977                                
978               {-
979                 c.f. Figure 16 and 17 in Haskell 1.1 report
980               -}  
981              paren_prec_limit
982                 | not is_infix = appPrecedence + 1
983                 | otherwise    = getPrecedence get_fixity dc_nm + 1
984
985 \end{code}
986
987 \begin{code}
988 getLRPrecs :: Bool -> FixityEnv -> Name -> [Integer]
989 getLRPrecs is_infix get_fixity nm = [lp, rp]
990     where
991      {-
992         Figuring out the fixities of the arguments to a constructor,
993         cf. Figures 16-18 in Haskell 1.1 report.
994      -}
995      (con_left_assoc, con_right_assoc) = isLRAssoc get_fixity nm
996      paren_con_prec = getPrecedence get_fixity nm
997
998      lp
999       | not is_infix   = appPrecedence + 1
1000       | con_left_assoc = paren_con_prec
1001       | otherwise      = paren_con_prec + 1
1002                   
1003      rp
1004       | not is_infix    = appPrecedence + 1
1005       | con_right_assoc = paren_con_prec
1006       | otherwise       = paren_con_prec + 1
1007                   
1008 appPrecedence :: Integer
1009 appPrecedence = fromIntegral maxPrecedence
1010
1011 getPrecedence :: FixityEnv -> Name -> Integer
1012 getPrecedence get_fixity nm 
1013    = case lookupFixity get_fixity nm of
1014         Fixity x _ -> fromIntegral x
1015
1016 isLRAssoc :: FixityEnv -> Name -> (Bool, Bool)
1017 isLRAssoc get_fixity nm =
1018      case lookupFixity get_fixity nm of
1019        Fixity _ InfixN -> (False, False)
1020        Fixity _ InfixR -> (False, True)
1021        Fixity _ InfixL -> (True,  False)
1022 \end{code}
1023
1024
1025 %************************************************************************
1026 %*                                                                      *
1027 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1028 %*                                                                      *
1029 %************************************************************************
1030
1031 \begin{verbatim}
1032 data Foo ... = ...
1033
1034 con2tag_Foo :: Foo ... -> Int#
1035 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
1036 maxtag_Foo  :: Int              -- ditto (NB: not unlifted)
1037 \end{verbatim}
1038
1039 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1040 fiddling around.
1041
1042 \begin{code}
1043 data TagThingWanted
1044   = GenCon2Tag | GenTag2Con | GenMaxTag
1045
1046 gen_tag_n_con_monobind
1047     :: (RdrName,            -- (proto)Name for the thing in question
1048         TyCon,              -- tycon in question
1049         TagThingWanted)
1050     -> RdrNameMonoBinds
1051
1052 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1053   | lots_of_constructors
1054   = mk_FunMonoBind (getSrcLoc tycon) rdr_name 
1055         [([VarPatIn a_RDR], HsApp getTag_Expr a_Expr)]
1056
1057   | otherwise
1058   = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
1059
1060   where
1061     lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1062
1063     mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
1064     mk_stuff var
1065       = ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
1066       where
1067         pat    = ConPatIn var_RDR (nOfThem (dataConSourceArity var) WildPatIn)
1068         var_RDR = qual_orig_name var
1069
1070 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1071   = mk_FunMonoBind (getSrcLoc tycon) rdr_name 
1072         [([ConPatIn mkInt_RDR [VarPatIn a_RDR]], 
1073            ExprWithTySig (HsApp tagToEnum_Expr a_Expr) 
1074                          (HsTyVar (qual_orig_name tycon)))]
1075
1076 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1077   = mk_easy_FunMonoBind (getSrcLoc tycon) 
1078                 rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
1079   where
1080     max_tag =  case (tyConDataCons tycon) of
1081                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1082
1083 \end{code}
1084
1085 %************************************************************************
1086 %*                                                                      *
1087 \subsection{Utility bits for generating bindings}
1088 %*                                                                      *
1089 %************************************************************************
1090
1091 @mk_easy_FunMonoBind fun pats binds expr@ generates:
1092 \begin{verbatim}
1093     fun pat1 pat2 ... patN = expr where binds
1094 \end{verbatim}
1095
1096 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
1097 multi-clause definitions; it generates:
1098 \begin{verbatim}
1099     fun p1a p1b ... p1N = e1
1100     fun p2a p2b ... p2N = e2
1101     ...
1102     fun pMa pMb ... pMN = eM
1103 \end{verbatim}
1104
1105 \begin{code}
1106 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
1107                     -> [RdrNameMonoBinds] -> RdrNameHsExpr
1108                     -> RdrNameMonoBinds
1109
1110 mk_easy_FunMonoBind loc fun pats binds expr
1111   = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
1112
1113 mk_easy_Match loc pats binds expr
1114   = mk_match loc pats expr (mkMonoBind (andMonoBindList binds) [] Recursive)
1115         -- The renamer expects everything in its input to be a
1116         -- "recursive" MonoBinds, and it is its job to sort things out
1117         -- from there.
1118
1119 mk_FunMonoBind  :: SrcLoc -> RdrName
1120                 -> [([RdrNamePat], RdrNameHsExpr)]
1121                 -> RdrNameMonoBinds
1122
1123 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
1124 mk_FunMonoBind loc fun pats_and_exprs
1125   = FunMonoBind fun False{-not infix-}
1126                 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
1127                 loc
1128
1129 mk_match loc pats expr binds
1130   = Match (map paren pats) Nothing 
1131           (GRHSs (unguardedRHS expr loc) binds placeHolderType)
1132   where
1133     paren p@(VarPatIn _) = p
1134     paren other_p        = ParPatIn other_p
1135 \end{code}
1136
1137 \begin{code}
1138 mkHsApps    f xs = foldl HsApp (HsVar f) xs
1139 mkHsVarApps f xs = foldl HsApp (HsVar f) (map HsVar xs)
1140
1141 mkHsIntLit n = HsLit (HsInt n)
1142 mkHsString s = HsString (mkFastString s)
1143 mkHsChar c   = HsChar   (ord c)
1144 \end{code}
1145
1146 ToDo: Better SrcLocs.
1147
1148 \begin{code}
1149 compare_gen_Case ::
1150           RdrName
1151           -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1152           -> RdrNameHsExpr -> RdrNameHsExpr
1153           -> RdrNameHsExpr
1154 careful_compare_Case :: -- checks for primitive types...
1155           Type
1156           -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1157           -> RdrNameHsExpr -> RdrNameHsExpr
1158           -> RdrNameHsExpr
1159
1160 cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b
1161         -- Was: compare_gen_Case cmp_eq_RDR
1162
1163 compare_gen_Case fun lt eq gt a b
1164   = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
1165       [mkSimpleMatch [ConPatIn ltTag_RDR []] lt placeHolderType generatedSrcLoc,
1166        mkSimpleMatch [ConPatIn eqTag_RDR []] eq placeHolderType generatedSrcLoc,
1167        mkSimpleMatch [ConPatIn gtTag_RDR []] gt placeHolderType generatedSrcLoc]
1168       generatedSrcLoc
1169
1170 careful_compare_Case ty lt eq gt a b
1171   | not (isUnLiftedType ty) =
1172        compare_gen_Case compare_RDR lt eq gt a b
1173   | otherwise               =
1174          -- we have to do something special for primitive things...
1175        HsIf (genOpApp a relevant_eq_op b)
1176             eq
1177             (HsIf (genOpApp a relevant_lt_op b) lt gt generatedSrcLoc)
1178             generatedSrcLoc
1179   where
1180     relevant_eq_op = assoc_ty_id eq_op_tbl ty
1181     relevant_lt_op = assoc_ty_id lt_op_tbl ty
1182
1183 assoc_ty_id tyids ty 
1184   = if null res then panic "assoc_ty"
1185     else head res
1186   where
1187     res = [id | (ty',id) <- tyids, ty `tcEqType` ty']
1188
1189 eq_op_tbl =
1190     [(charPrimTy,       eqH_Char_RDR)
1191     ,(intPrimTy,        eqH_Int_RDR)
1192     ,(wordPrimTy,       eqH_Word_RDR)
1193     ,(addrPrimTy,       eqH_Addr_RDR)
1194     ,(floatPrimTy,      eqH_Float_RDR)
1195     ,(doublePrimTy,     eqH_Double_RDR)
1196     ]
1197
1198 lt_op_tbl =
1199     [(charPrimTy,       ltH_Char_RDR)
1200     ,(intPrimTy,        ltH_Int_RDR)
1201     ,(wordPrimTy,       ltH_Word_RDR)
1202     ,(addrPrimTy,       ltH_Addr_RDR)
1203     ,(floatPrimTy,      ltH_Float_RDR)
1204     ,(doublePrimTy,     ltH_Double_RDR)
1205     ]
1206
1207 -----------------------------------------------------------------------
1208
1209 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1210
1211 and_Expr    a b = genOpApp a and_RDR    b
1212 append_Expr a b = genOpApp a append_RDR b
1213
1214 -----------------------------------------------------------------------
1215
1216 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1217 eq_Expr ty a b = genOpApp a eq_op b
1218  where
1219    eq_op
1220     | not (isUnLiftedType ty) = eq_RDR
1221     | otherwise               =
1222          -- we have to do something special for primitive things...
1223         assoc_ty_id eq_op_tbl ty
1224
1225 \end{code}
1226
1227 \begin{code}
1228 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
1229 untag_Expr tycon [] expr = expr
1230 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1231   = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1232       [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) placeHolderType generatedSrcLoc]
1233       generatedSrcLoc
1234
1235 cmp_tags_Expr :: RdrName                -- Comparison op
1236              -> RdrName -> RdrName      -- Things to compare
1237              -> RdrNameHsExpr           -- What to return if true
1238              -> RdrNameHsExpr           -- What to return if false
1239              -> RdrNameHsExpr
1240
1241 cmp_tags_Expr op a b true_case false_case
1242   = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case generatedSrcLoc
1243
1244 enum_from_to_Expr
1245         :: RdrNameHsExpr -> RdrNameHsExpr
1246         -> RdrNameHsExpr
1247 enum_from_then_to_Expr
1248         :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1249         -> RdrNameHsExpr
1250
1251 enum_from_to_Expr      f   t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1252 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1253
1254 showParen_Expr
1255         :: RdrNameHsExpr -> RdrNameHsExpr
1256         -> RdrNameHsExpr
1257
1258 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1259
1260 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1261
1262 nested_compose_Expr [e] = parenify e
1263 nested_compose_Expr (e:es)
1264   = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1265
1266 -- impossible_Expr is used in case RHSs that should never happen.
1267 -- We generate these to keep the desugarer from complaining that they *might* happen!
1268 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString "Urk! in TcGenDeriv")))
1269
1270 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1271 -- method. It is currently only used by Enum.{succ,pred}
1272 illegal_Expr meth tp msg = 
1273    HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString (meth ++ '{':tp ++ "}: " ++ msg))))
1274
1275 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1276 -- to include the value of a_RDR in the error string.
1277 illegal_toEnum_tag tp maxtag =
1278    HsApp (HsVar error_RDR) 
1279          (HsApp (HsApp (HsVar append_RDR)
1280                        (HsLit (HsString (mkFastString ("toEnum{" ++ tp ++ "}: tag (")))))
1281                        (HsApp (HsApp (HsApp 
1282                            (HsVar showsPrec_RDR)
1283                            (mkHsIntLit 0))
1284                            (HsVar a_RDR))
1285                            (HsApp (HsApp 
1286                                (HsVar append_RDR)
1287                                (HsLit (HsString (mkFastString ") is outside of enumeration's range (0,"))))
1288                                (HsApp (HsApp (HsApp 
1289                                         (HsVar showsPrec_RDR)
1290                                         (mkHsIntLit 0))
1291                                         (HsVar maxtag))
1292                                         (HsLit (HsString (mkFastString ")")))))))
1293
1294 parenify e@(HsVar _) = e
1295 parenify e           = HsPar e
1296
1297 -- genOpApp wraps brackets round the operator application, so that the
1298 -- renamer won't subsequently try to re-associate it. 
1299 -- For some reason the renamer doesn't reassociate it right, and I can't
1300 -- be bothered to find out why just now.
1301
1302 genOpApp e1 op e2 = mkHsOpApp e1 op e2
1303 \end{code}
1304
1305 \begin{code}
1306 qual_orig_name n = nameRdrName (getName n)
1307 varUnqual n      = mkUnqual varName n
1308
1309 zz_a_RDR        = varUnqual FSLIT("_a")
1310 a_RDR           = varUnqual FSLIT("a")
1311 b_RDR           = varUnqual FSLIT("b")
1312 c_RDR           = varUnqual FSLIT("c")
1313 d_RDR           = varUnqual FSLIT("d")
1314 ah_RDR          = varUnqual FSLIT("a#")
1315 bh_RDR          = varUnqual FSLIT("b#")
1316 ch_RDR          = varUnqual FSLIT("c#")
1317 dh_RDR          = varUnqual FSLIT("d#")
1318 cmp_eq_RDR      = varUnqual FSLIT("cmp_eq")
1319 rangeSize_RDR   = varUnqual FSLIT("rangeSize")
1320
1321 as_RDRs         = [ varUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1322 bs_RDRs         = [ varUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1323 cs_RDRs         = [ varUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1324
1325 zz_a_Expr       = HsVar zz_a_RDR
1326 a_Expr          = HsVar a_RDR
1327 b_Expr          = HsVar b_RDR
1328 c_Expr          = HsVar c_RDR
1329 d_Expr          = HsVar d_RDR
1330 ltTag_Expr      = HsVar ltTag_RDR
1331 eqTag_Expr      = HsVar eqTag_RDR
1332 gtTag_Expr      = HsVar gtTag_RDR
1333 false_Expr      = HsVar false_RDR
1334 true_Expr       = HsVar true_RDR
1335
1336 getTag_Expr     = HsVar getTag_RDR
1337 tagToEnum_Expr  = HsVar tagToEnumH_RDR
1338 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1339
1340 wildPat         = WildPatIn
1341 zz_a_Pat        = VarPatIn zz_a_RDR
1342 a_Pat           = VarPatIn a_RDR
1343 b_Pat           = VarPatIn b_RDR
1344 c_Pat           = VarPatIn c_RDR
1345 d_Pat           = VarPatIn d_RDR
1346
1347 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1348
1349 con2tag_RDR tycon = varUnqual (mkFastString ("con2tag_" ++ occNameString (getOccName tycon) ++ "#"))
1350 tag2con_RDR tycon = varUnqual (mkFastString ("tag2con_" ++ occNameString (getOccName tycon) ++ "#"))
1351 maxtag_RDR tycon  = varUnqual (mkFastString ("maxtag_"  ++ occNameString (getOccName tycon) ++ "#"))
1352 \end{code}