f940e169fac346489c7232d1c53561da3004c593
[ghc.git] / compiler / typecheck / TcGenDeriv.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5
6 TcGenDeriv: Generating derived instance declarations
7
8 This module is nominally ``subordinate'' to @TcDeriv@, which is the
9 ``official'' interface to deriving-related things.
10
11 This is where we do all the grimy bindings' generation.
12
13 \begin{code}
14 module TcGenDeriv (
15         DerivAuxBinds, isDupAux,
16
17         gen_Bounded_binds,
18         gen_Enum_binds,
19         gen_Eq_binds,
20         gen_Ix_binds,
21         gen_Ord_binds,
22         gen_Read_binds,
23         gen_Show_binds,
24         gen_Data_binds,
25         gen_Typeable_binds,
26         gen_Functor_binds, 
27         FFoldType(..), functorLikeTraverse, 
28         deepSubtypesContaining, foldDataConArgs,
29         gen_Foldable_binds,
30         gen_Traversable_binds,
31         genAuxBind
32     ) where
33
34 #include "HsVersions.h"
35
36 import HsSyn
37 import RdrName
38 import BasicTypes
39 import DataCon
40 import Name
41
42 import HscTypes
43 import PrelInfo
44 import PrelNames
45 import PrimOp
46 import SrcLoc
47 import TyCon
48 import TcType
49 import TysPrim
50 import TysWiredIn
51 import Type
52 import Var( TyVar )
53 import TypeRep
54 import VarSet
55 import State
56 import Util
57 import MonadUtils
58 import Outputable
59 import FastString
60 import Bag
61 import Data.List        ( partition, intersperse )
62 \end{code}
63
64 \begin{code}
65 type DerivAuxBinds = [DerivAuxBind]
66
67 data DerivAuxBind               -- Please add these auxiliary top-level bindings
68   = GenCon2Tag TyCon            -- The con2Tag for given TyCon
69   | GenTag2Con TyCon            -- ...ditto tag2Con
70   | GenMaxTag  TyCon            -- ...and maxTag
71
72         -- Scrap your boilerplate
73   | MkDataCon DataCon           -- For constructor C we get $cC :: Constr
74   | MkTyCon   TyCon             -- For tycon T we get       $tT :: DataType
75
76
77 isDupAux :: DerivAuxBind -> DerivAuxBind -> Bool
78 isDupAux (GenCon2Tag tc1) (GenCon2Tag tc2) = tc1 == tc2
79 isDupAux (GenTag2Con tc1) (GenTag2Con tc2) = tc1 == tc2
80 isDupAux (GenMaxTag tc1)  (GenMaxTag tc2)  = tc1 == tc2
81 isDupAux (MkDataCon dc1)  (MkDataCon dc2)  = dc1 == dc2
82 isDupAux (MkTyCon tc1)    (MkTyCon tc2)    = tc1 == tc2
83 isDupAux _                _                = False
84 \end{code}
85
86
87 %************************************************************************
88 %*                                                                      *
89                 Eq instances
90 %*                                                                      *
91 %************************************************************************
92
93 Here are the heuristics for the code we generate for @Eq@:
94 \begin{itemize}
95 \item
96   Let's assume we have a data type with some (possibly zero) nullary
97   data constructors and some ordinary, non-nullary ones (the rest,
98   also possibly zero of them).  Here's an example, with both \tr{N}ullary
99   and \tr{O}rdinary data cons.
100 \begin{verbatim}
101 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
102 \end{verbatim}
103
104 \item
105   For the ordinary constructors (if any), we emit clauses to do The
106   Usual Thing, e.g.,:
107
108 \begin{verbatim}
109 (==) (O1 a1 b1)    (O1 a2 b2)    = a1 == a2 && b1 == b2
110 (==) (O2 a1)       (O2 a2)       = a1 == a2
111 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
112 \end{verbatim}
113
114   Note: if we're comparing unlifted things, e.g., if \tr{a1} and
115   \tr{a2} are \tr{Float#}s, then we have to generate
116 \begin{verbatim}
117 case (a1 `eqFloat#` a2) of
118   r -> r
119 \end{verbatim}
120   for that particular test.
121
122 \item
123   If there are any nullary constructors, we emit a catch-all clause of
124   the form:
125
126 \begin{verbatim}
127 (==) a b  = case (con2tag_Foo a) of { a# ->
128             case (con2tag_Foo b) of { b# ->
129             case (a# ==# b#)     of {
130               r -> r
131             }}}
132 \end{verbatim}
133
134   If there aren't any nullary constructors, we emit a simpler
135   catch-all:
136 \begin{verbatim}
137 (==) a b  = False
138 \end{verbatim}
139
140 \item
141   For the @(/=)@ method, we normally just use the default method.
142
143   If the type is an enumeration type, we could/may/should? generate
144   special code that calls @con2tag_Foo@, much like for @(==)@ shown
145   above.
146
147 \item
148   We thought about doing this: If we're also deriving @Ord@ for this
149   tycon, we generate:
150 \begin{verbatim}
151 instance ... Eq (Foo ...) where
152   (==) a b  = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
153   (/=) a b  = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
154 \begin{verbatim}
155   However, that requires that \tr{Ord <whatever>} was put in the context
156   for the instance decl, which it probably wasn't, so the decls
157   produced don't get through the typechecker.
158 \end{itemize}
159
160
161 \begin{code}
162 gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
163 gen_Eq_binds loc tycon
164   = (method_binds, aux_binds)
165   where
166     (nullary_cons, nonnullary_cons)
167        | isNewTyCon tycon = ([], tyConDataCons tycon)
168        | otherwise            = partition isNullarySrcDataCon (tyConDataCons tycon)
169
170     no_nullary_cons = null nullary_cons
171
172     rest | no_nullary_cons
173          = case tyConSingleDataCon_maybe tycon of
174                   Just _ -> []
175                   Nothing -> -- if cons don't match, then False
176                      [([nlWildPat, nlWildPat], false_Expr)]
177          | otherwise -- calc. and compare the tags
178          = [([a_Pat, b_Pat],
179             untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
180                        (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
181
182     aux_binds | no_nullary_cons = []
183               | otherwise       = [GenCon2Tag tycon]
184
185     method_binds = listToBag [
186                         mk_FunBind loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest),
187                         mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
188                         nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))]
189
190     ------------------------------------------------------------------
191     pats_etc data_con
192       = let
193             con1_pat = nlConVarPat data_con_RDR as_needed
194             con2_pat = nlConVarPat data_con_RDR bs_needed
195
196             data_con_RDR = getRdrName data_con
197             con_arity   = length tys_needed
198             as_needed   = take con_arity as_RDRs
199             bs_needed   = take con_arity bs_RDRs
200             tys_needed  = dataConOrigArgTys data_con
201         in
202         ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
203       where
204         nested_eq_expr []  [] [] = true_Expr
205         nested_eq_expr tys as bs
206           = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
207           where
208             nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
209 \end{code}
210
211 %************************************************************************
212 %*                                                                      *
213         Ord instances
214 %*                                                                      *
215 %************************************************************************
216
217 For a derived @Ord@, we concentrate our attentions on @compare@
218 \begin{verbatim}
219 compare :: a -> a -> Ordering
220 data Ordering = LT | EQ | GT deriving ()
221 \end{verbatim}
222
223 We will use the same example data type as above:
224 \begin{verbatim}
225 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
226 \end{verbatim}
227
228 \begin{itemize}
229 \item
230   We do all the other @Ord@ methods with calls to @compare@:
231 \begin{verbatim}
232 instance ... (Ord <wurble> <wurble>) where
233     a <  b  = case (compare a b) of { LT -> True;  EQ -> False; GT -> False }
234     a <= b  = case (compare a b) of { LT -> True;  EQ -> True;  GT -> False }
235     a >= b  = case (compare a b) of { LT -> False; EQ -> True;  GT -> True  }
236     a >  b  = case (compare a b) of { LT -> False; EQ -> False; GT -> True  }
237
238     max a b = case (compare a b) of { LT -> b; EQ -> a;  GT -> a }
239     min a b = case (compare a b) of { LT -> a; EQ -> b;  GT -> b }
240
241     -- compare to come...
242 \end{verbatim}
243
244 \item
245   @compare@ always has two parts.  First, we use the compared
246   data-constructors' tags to deal with the case of different
247   constructors:
248 \begin{verbatim}
249 compare a b = case (con2tag_Foo a) of { a# ->
250               case (con2tag_Foo b) of { b# ->
251               case (a# ==# b#)     of {
252                True  -> cmp_eq a b
253                False -> case (a# <# b#) of
254                          True  -> _LT
255                          False -> _GT
256               }}}
257   where
258     cmp_eq = ... to come ...
259 \end{verbatim}
260
261 \item
262   We are only left with the ``help'' function @cmp_eq@, to deal with
263   comparing data constructors with the same tag.
264
265   For the ordinary constructors (if any), we emit the sorta-obvious
266   compare-style stuff; for our example:
267 \begin{verbatim}
268 cmp_eq (O1 a1 b1) (O1 a2 b2)
269   = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
270
271 cmp_eq (O2 a1) (O2 a2)
272   = compare a1 a2
273
274 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
275   = case (compare a1 a2) of {
276       LT -> LT;
277       GT -> GT;
278       EQ -> case compare b1 b2 of {
279               LT -> LT;
280               GT -> GT;
281               EQ -> compare c1 c2
282             }
283     }
284 \end{verbatim}
285
286   Again, we must be careful about unlifted comparisons.  For example,
287   if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
288   generate:
289
290 \begin{verbatim}
291 cmp_eq lt eq gt (O2 a1) (O2 a2)
292   = compareInt# a1 a2
293   -- or maybe the unfolded equivalent
294 \end{verbatim}
295
296 \item
297   For the remaining nullary constructors, we already know that the
298   tags are equal so:
299 \begin{verbatim}
300 cmp_eq _ _ = EQ
301 \end{verbatim}
302 \end{itemize}
303
304 If there is only one constructor in the Data Type we don't need the WildCard Pattern. 
305 JJQC-30-Nov-1997
306
307 \begin{code}
308 gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
309
310 gen_Ord_binds loc tycon
311   | Just (con, prim_tc) <- primWrapperType_maybe tycon
312   = gen_PrimOrd_binds con prim_tc
313
314   | otherwise 
315   = (unitBag compare, aux_binds)
316         -- `AndMonoBinds` compare       
317         -- The default declaration in PrelBase handles this
318   where
319     aux_binds | single_con_type = []
320               | otherwise       = [GenCon2Tag tycon]
321
322     compare = L loc (mkFunBind (L loc compare_RDR) compare_matches)
323     compare_matches = [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds]
324     cmp_eq_binds    = HsValBinds (ValBindsIn (unitBag cmp_eq) [])
325
326     compare_rhs
327         | single_con_type = cmp_eq_Expr a_Expr b_Expr
328         | otherwise
329         = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
330                   (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR
331                         (cmp_eq_Expr a_Expr b_Expr)     -- True case
332                         -- False case; they aren't equal
333                         -- So we need to do a less-than comparison on the tags
334                         (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))
335
336     tycon_data_cons = tyConDataCons tycon
337     single_con_type = isSingleton tycon_data_cons
338     (nullary_cons, nonnullary_cons)
339        | isNewTyCon tycon = ([], tyConDataCons tycon)
340        | otherwise        = partition isNullarySrcDataCon tycon_data_cons
341
342     cmp_eq = mk_FunBind loc cmp_eq_RDR cmp_eq_match
343     cmp_eq_match
344       | isEnumerationTyCon tycon
345                            -- We know the tags are equal, so if it's an enumeration TyCon,
346                            -- then there is nothing left to do
347                            -- Catch this specially to avoid warnings
348                            -- about overlapping patterns from the desugarer,
349                            -- and to avoid unnecessary pattern-matching
350       = [([nlWildPat,nlWildPat], eqTag_Expr)]
351       | otherwise
352       = map pats_etc nonnullary_cons ++
353         (if single_con_type then        -- Omit wildcards when there's just one 
354               []                        -- constructor, to silence desugarer
355         else
356               [([nlWildPat, nlWildPat], default_rhs)])
357
358     default_rhs | null nullary_cons = impossible_Expr   -- Keep desugarer from complaining about
359                                                         -- inexhaustive patterns
360                 | otherwise         = eqTag_Expr        -- Some nullary constructors;
361                                                         -- Tags are equal, no args => return EQ
362     pats_etc data_con
363         = ([con1_pat, con2_pat],
364            nested_compare_expr tys_needed as_needed bs_needed)
365         where
366           con1_pat = nlConVarPat data_con_RDR as_needed
367           con2_pat = nlConVarPat data_con_RDR bs_needed
368
369           data_con_RDR = getRdrName data_con
370           con_arity   = length tys_needed
371           as_needed   = take con_arity as_RDRs
372           bs_needed   = take con_arity bs_RDRs
373           tys_needed  = dataConOrigArgTys data_con
374
375           nested_compare_expr [ty] [a] [b]
376             = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b)
377
378           nested_compare_expr (ty:tys) (a:as) (b:bs)
379             = let eq_expr = nested_compare_expr tys as bs
380                 in  careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b)
381
382           nested_compare_expr _ _ _ = panic "nested_compare_expr"       -- Args always equal length
383 \end{code}
384
385 Note [Comparision of primitive types]
386 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
387 The general plan does not work well for data types like
388         data T = MkT Int# deriving( Ord )
389 The general plan defines the 'compare' method, gets (<) etc from it.  But
390 that means we get silly code like:
391    instance Ord T where
392      (>) (I# x) (I# y) = case <# x y of
393                             True -> False
394                             False -> case ==# x y of 
395                                        True  -> False
396                                        False -> True
397 We would prefer to use the (>#) primop.  See also Trac #2130
398                             
399
400 \begin{code}
401 gen_PrimOrd_binds :: DataCon -> TyCon ->  (LHsBinds RdrName, DerivAuxBinds)
402 -- See Note [Comparison of primitive types]
403 gen_PrimOrd_binds data_con prim_tc 
404   = (listToBag [mk_op lt_RDR lt_op, mk_op le_RDR le_op, 
405                 mk_op ge_RDR ge_op, mk_op gt_RDR gt_op], [])
406   where
407     mk_op op_RDR op = mk_FunBind (getSrcSpan data_con) op_RDR 
408                                  [([apat, bpat], genOpApp a_Expr (primOpRdrName op) b_Expr)]
409     con_RDR = getRdrName data_con
410     apat = nlConVarPat con_RDR [a_RDR]
411     bpat = nlConVarPat con_RDR [b_RDR]
412
413     (lt_op, le_op, ge_op, gt_op)
414        | prim_tc == charPrimTyCon   = (CharLtOp,   CharLeOp,   CharGeOp,   CharGtOp)
415        | prim_tc == intPrimTyCon    = (IntLtOp,    IntLeOp,    IntGeOp,    IntGtOp)
416        | prim_tc == wordPrimTyCon   = (WordLtOp,   WordLeOp,   WordGeOp,   WordGtOp)
417        | prim_tc == addrPrimTyCon   = (AddrLtOp,   AddrLeOp,   AddrGeOp,   AddrGtOp)
418        | prim_tc == floatPrimTyCon  = (FloatLtOp,  FloatLeOp,  FloatGeOp,  FloatGtOp)
419        | prim_tc == doublePrimTyCon = (DoubleLtOp, DoubleLeOp, DoubleGeOp, DoubleGtOp)
420        | otherwise = pprPanic "Unexpected primitive tycon" (ppr prim_tc)
421
422
423 primWrapperType_maybe :: TyCon -> Maybe (DataCon, TyCon)
424 -- True of data types that are wrappers around prmitive types
425 --      data T = MkT Word#
426 -- For these we want to generate all the (<), (<=) etc operations individually
427 primWrapperType_maybe tc 
428   | [con] <- tyConDataCons tc
429   , [ty]  <- dataConOrigArgTys con
430   , Just (prim_tc, []) <- tcSplitTyConApp_maybe ty
431   , isPrimTyCon prim_tc
432   = Just (con, prim_tc)
433   | otherwise
434   = Nothing
435 \end{code}
436
437 %************************************************************************
438 %*                                                                      *
439         Enum instances
440 %*                                                                      *
441 %************************************************************************
442
443 @Enum@ can only be derived for enumeration types.  For a type
444 \begin{verbatim}
445 data Foo ... = N1 | N2 | ... | Nn
446 \end{verbatim}
447
448 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
449 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
450
451 \begin{verbatim}
452 instance ... Enum (Foo ...) where
453     succ x   = toEnum (1 + fromEnum x)
454     pred x   = toEnum (fromEnum x - 1)
455
456     toEnum i = tag2con_Foo i
457
458     enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
459
460     -- or, really...
461     enumFrom a
462       = case con2tag_Foo a of
463           a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
464
465    enumFromThen a b
466      = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
467
468     -- or, really...
469     enumFromThen a b
470       = case con2tag_Foo a of { a# ->
471         case con2tag_Foo b of { b# ->
472         map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
473         }}
474 \end{verbatim}
475
476 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
477
478 \begin{code}
479 gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
480 gen_Enum_binds loc tycon
481   = (method_binds, aux_binds)
482   where
483     method_binds = listToBag [
484                         succ_enum,
485                         pred_enum,
486                         to_enum,
487                         enum_from,
488                         enum_from_then,
489                         from_enum
490                     ]
491     aux_binds = [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon]
492
493     occ_nm = getOccString tycon
494
495     succ_enum
496       = mk_easy_FunBind loc succ_RDR [a_Pat] $
497         untag_Expr tycon [(a_RDR, ah_RDR)] $
498         nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
499                                nlHsVarApps intDataCon_RDR [ah_RDR]])
500              (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
501              (nlHsApp (nlHsVar (tag2con_RDR tycon))
502                     (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
503                                         nlHsIntLit 1]))
504                     
505     pred_enum
506       = mk_easy_FunBind loc pred_RDR [a_Pat] $
507         untag_Expr tycon [(a_RDR, ah_RDR)] $
508         nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
509                                nlHsVarApps intDataCon_RDR [ah_RDR]])
510              (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
511              (nlHsApp (nlHsVar (tag2con_RDR tycon))
512                            (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
513                                                nlHsLit (HsInt (-1))]))
514
515     to_enum
516       = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
517         nlHsIf (nlHsApps and_RDR
518                 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
519                  nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
520              (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
521              (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
522
523     enum_from
524       = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
525           untag_Expr tycon [(a_RDR, ah_RDR)] $
526           nlHsApps map_RDR 
527                 [nlHsVar (tag2con_RDR tycon),
528                  nlHsPar (enum_from_to_Expr
529                             (nlHsVarApps intDataCon_RDR [ah_RDR])
530                             (nlHsVar (maxtag_RDR tycon)))]
531
532     enum_from_then
533       = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
534           untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
535           nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
536             nlHsPar (enum_from_then_to_Expr
537                     (nlHsVarApps intDataCon_RDR [ah_RDR])
538                     (nlHsVarApps intDataCon_RDR [bh_RDR])
539                     (nlHsIf  (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
540                                              nlHsVarApps intDataCon_RDR [bh_RDR]])
541                            (nlHsIntLit 0)
542                            (nlHsVar (maxtag_RDR tycon))
543                            ))
544
545     from_enum
546       = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
547           untag_Expr tycon [(a_RDR, ah_RDR)] $
548           (nlHsVarApps intDataCon_RDR [ah_RDR])
549 \end{code}
550
551 %************************************************************************
552 %*                                                                      *
553         Bounded instances
554 %*                                                                      *
555 %************************************************************************
556
557 \begin{code}
558 gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
559 gen_Bounded_binds loc tycon
560   | isEnumerationTyCon tycon
561   = (listToBag [ min_bound_enum, max_bound_enum ], [])
562   | otherwise
563   = ASSERT(isSingleton data_cons)
564     (listToBag [ min_bound_1con, max_bound_1con ], [])
565   where
566     data_cons = tyConDataCons tycon
567
568     ----- enum-flavored: ---------------------------
569     min_bound_enum = mkVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
570     max_bound_enum = mkVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
571
572     data_con_1    = head data_cons
573     data_con_N    = last data_cons
574     data_con_1_RDR = getRdrName data_con_1
575     data_con_N_RDR = getRdrName data_con_N
576
577     ----- single-constructor-flavored: -------------
578     arity          = dataConSourceArity data_con_1
579
580     min_bound_1con = mkVarBind loc minBound_RDR $
581                      nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
582     max_bound_1con = mkVarBind loc maxBound_RDR $
583                      nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
584 \end{code}
585
586 %************************************************************************
587 %*                                                                      *
588         Ix instances
589 %*                                                                      *
590 %************************************************************************
591
592 Deriving @Ix@ is only possible for enumeration types and
593 single-constructor types.  We deal with them in turn.
594
595 For an enumeration type, e.g.,
596 \begin{verbatim}
597     data Foo ... = N1 | N2 | ... | Nn
598 \end{verbatim}
599 things go not too differently from @Enum@:
600 \begin{verbatim}
601 instance ... Ix (Foo ...) where
602     range (a, b)
603       = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
604
605     -- or, really...
606     range (a, b)
607       = case (con2tag_Foo a) of { a# ->
608         case (con2tag_Foo b) of { b# ->
609         map tag2con_Foo (enumFromTo (I# a#) (I# b#))
610         }}
611
612     -- Generate code for unsafeIndex, becuase using index leads
613     -- to lots of redundant range tests
614     unsafeIndex c@(a, b) d
615       = case (con2tag_Foo d -# con2tag_Foo a) of
616                r# -> I# r#
617
618     inRange (a, b) c
619       = let
620             p_tag = con2tag_Foo c
621         in
622         p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
623
624     -- or, really...
625     inRange (a, b) c
626       = case (con2tag_Foo a)   of { a_tag ->
627         case (con2tag_Foo b)   of { b_tag ->
628         case (con2tag_Foo c)   of { c_tag ->
629         if (c_tag >=# a_tag) then
630           c_tag <=# b_tag
631         else
632           False
633         }}}
634 \end{verbatim}
635 (modulo suitable case-ification to handle the unlifted tags)
636
637 For a single-constructor type (NB: this includes all tuples), e.g.,
638 \begin{verbatim}
639     data Foo ... = MkFoo a b Int Double c c
640 \end{verbatim}
641 we follow the scheme given in Figure~19 of the Haskell~1.2 report
642 (p.~147).
643
644 \begin{code}
645 gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
646
647 gen_Ix_binds loc tycon
648   | isEnumerationTyCon tycon
649   = (enum_ixes, [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon])
650   | otherwise
651   = (single_con_ixes, [GenCon2Tag tycon])
652   where
653     --------------------------------------------------------------
654     enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
655
656     enum_range
657       = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
658           untag_Expr tycon [(a_RDR, ah_RDR)] $
659           untag_Expr tycon [(b_RDR, bh_RDR)] $
660           nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
661               nlHsPar (enum_from_to_Expr
662                         (nlHsVarApps intDataCon_RDR [ah_RDR])
663                         (nlHsVarApps intDataCon_RDR [bh_RDR]))
664
665     enum_index
666       = mk_easy_FunBind loc unsafeIndex_RDR 
667                 [noLoc (AsPat (noLoc c_RDR) 
668                            (nlTuplePat [a_Pat, nlWildPat] Boxed)), 
669                                 d_Pat] (
670            untag_Expr tycon [(a_RDR, ah_RDR)] (
671            untag_Expr tycon [(d_RDR, dh_RDR)] (
672            let
673                 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
674            in
675            nlHsCase
676              (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
677              [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
678            ))
679         )
680
681     enum_inRange
682       = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
683           untag_Expr tycon [(a_RDR, ah_RDR)] (
684           untag_Expr tycon [(b_RDR, bh_RDR)] (
685           untag_Expr tycon [(c_RDR, ch_RDR)] (
686           nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
687              (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
688           ) {-else-} (
689              false_Expr
690           ))))
691
692     --------------------------------------------------------------
693     single_con_ixes 
694       = listToBag [single_con_range, single_con_index, single_con_inRange]
695
696     data_con
697       = case tyConSingleDataCon_maybe tycon of -- just checking...
698           Nothing -> panic "get_Ix_binds"
699           Just dc -> dc
700
701     con_arity    = dataConSourceArity data_con
702     data_con_RDR = getRdrName data_con
703
704     as_needed = take con_arity as_RDRs
705     bs_needed = take con_arity bs_RDRs
706     cs_needed = take con_arity cs_RDRs
707
708     con_pat  xs  = nlConVarPat data_con_RDR xs
709     con_expr     = nlHsVarApps data_con_RDR cs_needed
710
711     --------------------------------------------------------------
712     single_con_range
713       = mk_easy_FunBind loc range_RDR 
714           [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
715         nlHsDo ListComp stmts con_expr
716       where
717         stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
718
719         mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
720                                  (nlHsApp (nlHsVar range_RDR) 
721                                         (nlTuple [nlHsVar a, nlHsVar b] Boxed))
722
723     ----------------
724     single_con_index
725       = mk_easy_FunBind loc unsafeIndex_RDR 
726                 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, 
727                  con_pat cs_needed] 
728         -- We need to reverse the order we consider the components in
729         -- so that
730         --     range (l,u) !! index (l,u) i == i   -- when i is in range
731         -- (from http://haskell.org/onlinereport/ix.html) holds.
732                 (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
733       where
734         -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
735         mk_index []        = nlHsIntLit 0
736         mk_index [(l,u,i)] = mk_one l u i
737         mk_index ((l,u,i) : rest)
738           = genOpApp (
739                 mk_one l u i
740             ) plus_RDR (
741                 genOpApp (
742                     (nlHsApp (nlHsVar unsafeRangeSize_RDR) 
743                            (nlTuple [nlHsVar l, nlHsVar u] Boxed))
744                 ) times_RDR (mk_index rest)
745            )
746         mk_one l u i
747           = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i]
748
749     ------------------
750     single_con_inRange
751       = mk_easy_FunBind loc inRange_RDR 
752                 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, 
753                  con_pat cs_needed] $
754           foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
755       where
756         in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
757                                                nlHsVar c]
758 \end{code}
759
760 %************************************************************************
761 %*                                                                      *
762         Read instances
763 %*                                                                      *
764 %************************************************************************
765
766 Example
767
768   infix 4 %%
769   data T = Int %% Int
770          | T1 { f1 :: Int }
771          | T2 T
772
773
774 instance Read T where
775   readPrec =
776     parens
777     ( prec 4 (
778         do x           <- ReadP.step Read.readPrec
779            Symbol "%%" <- Lex.lex
780            y           <- ReadP.step Read.readPrec
781            return (x %% y))
782       +++
783       prec (appPrec+1) (
784         -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
785         -- Record construction binds even more tightly than application
786         do Ident "T1" <- Lex.lex
787            Punc '{' <- Lex.lex
788            Ident "f1" <- Lex.lex
789            Punc '=' <- Lex.lex
790            x          <- ReadP.reset Read.readPrec
791            Punc '}' <- Lex.lex
792            return (T1 { f1 = x }))
793       +++
794       prec appPrec (
795         do Ident "T2" <- Lex.lexP
796            x          <- ReadP.step Read.readPrec
797            return (T2 x))
798     )
799
800   readListPrec = readListPrecDefault
801   readList     = readListDefault
802
803
804 \begin{code}
805 gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
806
807 gen_Read_binds get_fixity loc tycon
808   = (listToBag [read_prec, default_readlist, default_readlistprec], [])
809   where
810     -----------------------------------------------------------------------
811     default_readlist 
812         = mkVarBind loc readList_RDR     (nlHsVar readListDefault_RDR)
813
814     default_readlistprec
815         = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
816     -----------------------------------------------------------------------
817
818     data_cons = tyConDataCons tycon
819     (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
820     
821     read_prec = mkVarBind loc readPrec_RDR
822                               (nlHsApp (nlHsVar parens_RDR) read_cons)
823
824     read_cons             = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
825     read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
826     
827     read_nullary_cons 
828       = case nullary_cons of
829             []    -> []
830             [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
831                                     (result_expr con [])]
832             _     -> [nlHsApp (nlHsVar choose_RDR) 
833                               (nlList (map mk_pair nullary_cons))]
834     
835     mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)), 
836                            result_expr con []]
837                           Boxed
838     
839     read_non_nullary_con data_con
840       | is_infix  = mk_parser infix_prec  infix_stmts  body
841       | is_record = mk_parser record_prec record_stmts body
842 --              Using these two lines instead allows the derived
843 --              read for infix and record bindings to read the prefix form
844 --      | is_infix  = mk_alt prefix_parser (mk_parser infix_prec  infix_stmts  body)
845 --      | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
846       | otherwise = prefix_parser
847       where
848         body = result_expr data_con as_needed
849         con_str = data_con_str data_con
850         
851         prefix_parser = mk_parser prefix_prec prefix_stmts body
852
853         read_prefix_con
854             | isSym con_str = [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"]
855             | otherwise     = [bindLex (ident_pat con_str)]
856          
857         read_infix_con
858             | isSym con_str = [bindLex (symbol_pat con_str)]
859             | otherwise     = [read_punc "`", bindLex (ident_pat con_str), read_punc "`"]
860
861         prefix_stmts            -- T a b c
862           = read_prefix_con ++ read_args
863
864         infix_stmts             -- a %% b, or  a `T` b 
865           = [read_a1]
866             ++ read_infix_con
867             ++ [read_a2]
868      
869         record_stmts            -- T { f1 = a, f2 = b }
870           = read_prefix_con 
871             ++ [read_punc "{"]
872             ++ concat (intersperse [read_punc ","] field_stmts)
873             ++ [read_punc "}"]
874      
875         field_stmts  = zipWithEqual "lbl_stmts" read_field labels as_needed
876      
877         con_arity    = dataConSourceArity data_con
878         labels       = dataConFieldLabels data_con
879         dc_nm        = getName data_con
880         is_infix     = dataConIsInfix data_con
881         is_record    = length labels > 0
882         as_needed    = take con_arity as_RDRs
883         read_args    = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
884         (read_a1:read_a2:_) = read_args
885         
886         prefix_prec = appPrecedence
887         infix_prec  = getPrecedence get_fixity dc_nm
888         record_prec = appPrecedence + 1 -- Record construction binds even more tightly
889                                         -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
890
891     ------------------------------------------------------------------------
892     --          Helpers
893     ------------------------------------------------------------------------
894     mk_alt e1 e2       = genOpApp e1 alt_RDR e2                                 -- e1 +++ e2
895     mk_parser p ss b   = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b]   -- prec p (do { ss ; b })
896     bindLex pat        = noLoc (mkBindStmt pat (nlHsVar lexP_RDR))              -- pat <- lexP
897     con_app con as     = nlHsVarApps (getRdrName con) as                        -- con as
898     result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as)         -- return (con as)
899     
900     punc_pat s   = nlConPat punc_RDR   [nlLitPat (mkHsString s)]  -- Punc 'c'
901     ident_pat s  = nlConPat ident_RDR  [nlLitPat (mkHsString s)]  -- Ident "foo"
902     symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)]  -- Symbol ">>"
903     
904     data_con_str con = occNameString (getOccName con)
905     
906     read_punc c = bindLex (punc_pat c)
907     read_arg a ty = ASSERT( not (isUnLiftedType ty) )
908                     noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
909     
910     read_field lbl a = read_lbl lbl ++
911                        [read_punc "=",
912                         noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
913
914         -- When reading field labels we might encounter
915         --      a  = 3
916         --      _a = 3
917         -- or   (#) = 4
918         -- Note the parens!
919     read_lbl lbl | isSym lbl_str 
920                  = [read_punc "(", 
921                     bindLex (symbol_pat lbl_str),
922                     read_punc ")"]
923                  | otherwise
924                  = [bindLex (ident_pat lbl_str)]
925                  where  
926                    lbl_str = occNameString (getOccName lbl) 
927 \end{code}
928
929
930 %************************************************************************
931 %*                                                                      *
932         Show instances
933 %*                                                                      *
934 %************************************************************************
935
936 Example
937
938     infixr 5 :^:
939
940     data Tree a =  Leaf a  |  Tree a :^: Tree a
941
942     instance (Show a) => Show (Tree a) where
943
944         showsPrec d (Leaf m) = showParen (d > app_prec) showStr
945           where
946              showStr = showString "Leaf " . showsPrec (app_prec+1) m
947
948         showsPrec d (u :^: v) = showParen (d > up_prec) showStr
949           where
950              showStr = showsPrec (up_prec+1) u . 
951                        showString " :^: "      .
952                        showsPrec (up_prec+1) v
953                 -- Note: right-associativity of :^: ignored
954
955     up_prec  = 5    -- Precedence of :^:
956     app_prec = 10   -- Application has precedence one more than
957                     -- the most tightly-binding operator
958
959 \begin{code}
960 gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
961
962 gen_Show_binds get_fixity loc tycon
963   = (listToBag [shows_prec, show_list], [])
964   where
965     -----------------------------------------------------------------------
966     show_list = mkVarBind loc showList_RDR
967                   (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
968     -----------------------------------------------------------------------
969     shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
970       where
971         pats_etc data_con
972           | nullary_con =  -- skip the showParen junk...
973              ASSERT(null bs_needed)
974              ([nlWildPat, con_pat], mk_showString_app con_str)
975           | otherwise   =
976              ([a_Pat, con_pat],
977                   showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
978                                  (nlHsPar (nested_compose_Expr show_thingies)))
979             where
980              data_con_RDR  = getRdrName data_con
981              con_arity     = dataConSourceArity data_con
982              bs_needed     = take con_arity bs_RDRs
983              arg_tys       = dataConOrigArgTys data_con         -- Correspond 1-1 with bs_needed
984              con_pat       = nlConVarPat data_con_RDR bs_needed
985              nullary_con   = con_arity == 0
986              labels        = dataConFieldLabels data_con
987              lab_fields    = length labels
988              record_syntax = lab_fields > 0
989
990              dc_nm          = getName data_con
991              dc_occ_nm      = getOccName data_con
992              con_str        = occNameString dc_occ_nm
993              op_con_str     = wrapOpParens con_str
994              backquote_str  = wrapOpBackquotes con_str
995
996              show_thingies 
997                 | is_infix      = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
998                 | record_syntax = mk_showString_app (op_con_str ++ " {") : 
999                                   show_record_args ++ [mk_showString_app "}"]
1000                 | otherwise     = mk_showString_app (op_con_str ++ " ") : show_prefix_args
1001                 
1002              show_label l = mk_showString_app (nm ++ " = ")
1003                         -- Note the spaces around the "=" sign.  If we don't have them
1004                         -- then we get Foo { x=-1 } and the "=-" parses as a single
1005                         -- lexeme.  Only the space after the '=' is necessary, but
1006                         -- it seems tidier to have them both sides.
1007                  where
1008                    occ_nm   = getOccName l
1009                    nm       = wrapOpParens (occNameString occ_nm)
1010
1011              show_args               = zipWith show_arg bs_needed arg_tys
1012              (show_arg1:show_arg2:_) = show_args
1013              show_prefix_args        = intersperse (nlHsVar showSpace_RDR) show_args
1014
1015                 --  Assumption for record syntax: no of fields == no of labelled fields 
1016                 --            (and in same order)
1017              show_record_args = concat $
1018                                 intersperse [mk_showString_app ", "] $
1019                                 [ [show_label lbl, arg] 
1020                                 | (lbl,arg) <- zipEqual "gen_Show_binds" 
1021                                                         labels show_args ]
1022                                
1023                 -- Generates (showsPrec p x) for argument x, but it also boxes
1024                 -- the argument first if necessary.  Note that this prints unboxed
1025                 -- things without any '#' decorations; could change that if need be
1026              show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec), 
1027                                                          box_if_necy "Show" tycon (nlHsVar b) arg_ty]
1028
1029                 -- Fixity stuff
1030              is_infix = dataConIsInfix data_con
1031              con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1032              arg_prec | record_syntax = 0       -- Record fields don't need parens
1033                       | otherwise     = con_prec_plus_one
1034
1035 wrapOpParens :: String -> String
1036 wrapOpParens s | isSym s   = '(' : s ++ ")"
1037                | otherwise = s
1038
1039 wrapOpBackquotes :: String -> String
1040 wrapOpBackquotes s | isSym s   = s
1041                    | otherwise = '`' : s ++ "`"
1042
1043 isSym :: String -> Bool
1044 isSym ""      = False
1045 isSym (c : _) = startsVarSym c || startsConSym c
1046
1047 mk_showString_app :: String -> LHsExpr RdrName
1048 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1049 \end{code}
1050
1051 \begin{code}
1052 getPrec :: Bool -> FixityEnv -> Name -> Integer
1053 getPrec is_infix get_fixity nm 
1054   | not is_infix   = appPrecedence
1055   | otherwise      = getPrecedence get_fixity nm
1056                   
1057 appPrecedence :: Integer
1058 appPrecedence = fromIntegral maxPrecedence + 1
1059   -- One more than the precedence of the most 
1060   -- tightly-binding operator
1061
1062 getPrecedence :: FixityEnv -> Name -> Integer
1063 getPrecedence get_fixity nm 
1064    = case lookupFixity get_fixity nm of
1065         Fixity x _assoc -> fromIntegral x
1066           -- NB: the Report says that associativity is not taken 
1067           --     into account for either Read or Show; hence we 
1068           --     ignore associativity here
1069 \end{code}
1070
1071
1072 %************************************************************************
1073 %*                                                                      *
1074 \subsection{Typeable}
1075 %*                                                                      *
1076 %************************************************************************
1077
1078 From the data type
1079
1080         data T a b = ....
1081
1082 we generate
1083
1084         instance Typeable2 T where
1085                 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1086
1087 We are passed the Typeable2 class as well as T
1088
1089 \begin{code}
1090 gen_Typeable_binds :: SrcSpan -> TyCon -> LHsBinds RdrName
1091 gen_Typeable_binds loc tycon
1092   = unitBag $
1093         mk_easy_FunBind loc 
1094                 (mk_typeOf_RDR tycon)   -- Name of appropriate type0f function
1095                 [nlWildPat] 
1096                 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1097   where
1098     tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
1099
1100 mk_typeOf_RDR :: TyCon -> RdrName
1101 -- Use the arity of the TyCon to make the right typeOfn function
1102 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1103                 where
1104                   arity = tyConArity tycon
1105                   suffix | arity == 0 = ""
1106                          | otherwise  = show arity
1107 \end{code}
1108
1109
1110
1111 %************************************************************************
1112 %*                                                                      *
1113         Data instances
1114 %*                                                                      *
1115 %************************************************************************
1116
1117 From the data type
1118
1119   data T a b = T1 a b | T2
1120
1121 we generate
1122
1123   $cT1 = mkDataCon $dT "T1" Prefix
1124   $cT2 = mkDataCon $dT "T2" Prefix
1125   $dT  = mkDataType "Module.T" [] [$con_T1, $con_T2]
1126   -- the [] is for field labels.
1127
1128   instance (Data a, Data b) => Data (T a b) where
1129     gfoldl k z (T1 a b) = z T `k` a `k` b
1130     gfoldl k z T2           = z T2
1131     -- ToDo: add gmapT,Q,M, gfoldr
1132  
1133     gunfold k z c = case conIndex c of
1134                         I# 1# -> k (k (z T1))
1135                         I# 2# -> z T2
1136
1137     toConstr (T1 _ _) = $cT1
1138     toConstr T2       = $cT2
1139     
1140     dataTypeOf _ = $dT
1141
1142     dataCast1 = gcast1   -- If T :: * -> *
1143     dataCast2 = gcast2   -- if T :: * -> * -> *
1144
1145     
1146 \begin{code}
1147 gen_Data_binds :: SrcSpan
1148                -> TyCon 
1149                -> (LHsBinds RdrName,    -- The method bindings
1150                    DerivAuxBinds)       -- Auxiliary bindings
1151 gen_Data_binds loc tycon
1152   = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
1153      `unionBags` gcast_binds,
1154                 -- Auxiliary definitions: the data type and constructors
1155      MkTyCon tycon : map MkDataCon data_cons)
1156   where
1157     data_cons  = tyConDataCons tycon
1158     n_cons     = length data_cons
1159     one_constr = n_cons == 1
1160
1161         ------------ gfoldl
1162     gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons)
1163     gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed], 
1164                        foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1165                    where
1166                      con_name ::  RdrName
1167                      con_name = getRdrName con
1168                      as_needed = take (dataConSourceArity con) as_RDRs
1169                      mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1170
1171         ------------ gunfold
1172     gunfold_bind = mk_FunBind loc
1173                               gunfold_RDR
1174                               [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat], 
1175                                 gunfold_rhs)]
1176
1177     gunfold_rhs 
1178         | one_constr = mk_unfold_rhs (head data_cons)   -- No need for case
1179         | otherwise  = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr) 
1180                                 (map gunfold_alt data_cons)
1181
1182     gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1183     mk_unfold_rhs dc = foldr nlHsApp
1184                            (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1185                            (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1186
1187     mk_unfold_pat dc    -- Last one is a wild-pat, to avoid 
1188                         -- redundant test, and annoying warning
1189       | tag-fIRST_TAG == n_cons-1 = nlWildPat   -- Last constructor
1190       | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1191       where 
1192         tag = dataConTag dc
1193                           
1194         ------------ toConstr
1195     toCon_bind = mk_FunBind loc toConstr_RDR (map to_con_eqn data_cons)
1196     to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1197     
1198         ------------ dataTypeOf
1199     dataTypeOf_bind = mk_easy_FunBind
1200                         loc
1201                         dataTypeOf_RDR
1202                         [nlWildPat]
1203                         (nlHsVar (mk_data_type_name tycon))
1204
1205         ------------ gcast1/2
1206     tycon_kind = tyConKind tycon
1207     gcast_binds | tycon_kind `eqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR
1208                 | tycon_kind `eqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
1209                 | otherwise           = emptyBag
1210     mk_gcast dataCast_RDR gcast_RDR 
1211       = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR] 
1212                                  (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
1213
1214
1215 kind1, kind2 :: Kind
1216 kind1 = liftedTypeKind `mkArrowKind` liftedTypeKind
1217 kind2 = liftedTypeKind `mkArrowKind` kind1
1218
1219 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
1220     mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
1221     dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR :: RdrName
1222 gfoldl_RDR     = varQual_RDR gENERICS (fsLit "gfoldl")
1223 gunfold_RDR    = varQual_RDR gENERICS (fsLit "gunfold")
1224 toConstr_RDR   = varQual_RDR gENERICS (fsLit "toConstr")
1225 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1226 dataCast1_RDR  = varQual_RDR gENERICS (fsLit "dataCast1")
1227 dataCast2_RDR  = varQual_RDR gENERICS (fsLit "dataCast2")
1228 gcast1_RDR     = varQual_RDR tYPEABLE (fsLit "gcast1")
1229 gcast2_RDR     = varQual_RDR tYPEABLE (fsLit "gcast2")
1230 mkConstr_RDR   = varQual_RDR gENERICS (fsLit "mkConstr")
1231 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1232 conIndex_RDR   = varQual_RDR gENERICS (fsLit "constrIndex")
1233 prefix_RDR     = dataQual_RDR gENERICS (fsLit "Prefix")
1234 infix_RDR      = dataQual_RDR gENERICS (fsLit "Infix")
1235 \end{code}
1236
1237
1238
1239 %************************************************************************
1240 %*                                                                      *
1241                         Functor instances
1242
1243  see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1244
1245 %*                                                                      *
1246 %************************************************************************
1247
1248 For the data type:
1249
1250   data T a = T1 Int a | T2 (T a)
1251
1252 We generate the instance:
1253
1254   instance Functor T where
1255       fmap f (T1 b1 a) = T1 b1 (f a)
1256       fmap f (T2 ta)   = T2 (fmap f ta)
1257
1258 Notice that we don't simply apply 'fmap' to the constructor arguments.
1259 Rather 
1260   - Do nothing to an argument whose type doesn't mention 'a'
1261   - Apply 'f' to an argument of type 'a'
1262   - Apply 'fmap f' to other arguments 
1263 That's why we have to recurse deeply into the constructor argument types,
1264 rather than just one level, as we typically do.
1265
1266 What about types with more than one type parameter?  In general, we only 
1267 derive Functor for the last position:
1268
1269   data S a b = S1 [b] | S2 (a, T a b)
1270   instance Functor (S a) where
1271     fmap f (S1 bs)    = S1 (fmap f bs)
1272     fmap f (S2 (p,q)) = S2 (a, fmap f q)
1273
1274 However, we have special cases for
1275          - tuples
1276          - functions
1277
1278 More formally, we write the derivation of fmap code over type variable
1279 'a for type 'b as ($fmap 'a 'b).  In this general notation the derived
1280 instance for T is:
1281
1282   instance Functor T where
1283       fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
1284       fmap f (T2 x1)    = T2 ($(fmap 'a '(T a)) x1)
1285
1286   $(fmap 'a 'b)         x  =  x     -- when b does not contain a
1287   $(fmap 'a 'a)         x  =  f x
1288   $(fmap 'a '(b1,b2))   x  =  case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
1289   $(fmap 'a '(T b1 b2)) x  =  fmap $(fmap 'a 'b2) x   -- when a only occurs in the last parameter, b2
1290   $(fmap 'a '(b -> c))  x  =  \b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
1291
1292 For functions, the type parameter 'a can occur in a contravariant position,
1293 which means we need to derive a function like:
1294
1295   cofmap :: (a -> b) -> (f b -> f a)
1296
1297 This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
1298
1299   $(cofmap 'a 'b)         x  =  x     -- when b does not contain a
1300   $(cofmap 'a 'a)         x  =  error "type variable in contravariant position"
1301   $(cofmap 'a '(b1,b2))   x  =  case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
1302   $(cofmap 'a '[b])       x  =  map $(cofmap 'a 'b) x
1303   $(cofmap 'a '(T b1 b2)) x  =  fmap $(cofmap 'a 'b2) x   -- when a only occurs in the last parameter, b2
1304   $(cofmap 'a '(b -> c))  x  =  \b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
1305
1306 \begin{code}
1307 gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1308 gen_Functor_binds loc tycon
1309   = (unitBag fmap_bind, [])
1310   where
1311     data_cons = tyConDataCons tycon
1312
1313     fmap_bind = L loc $ mkFunBind (L loc fmap_RDR) (map fmap_eqn data_cons)
1314     fmap_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1315       where 
1316         parts = foldDataConArgs ft_fmap con
1317
1318     ft_fmap :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1319     -- Tricky higher order type; I can't say I fully understand this code :-(
1320     ft_fmap = FT { ft_triv = \x -> return x                    -- fmap f x = x
1321                  , ft_var  = \x -> return (nlHsApp f_Expr x)   -- fmap f x = f x
1322                  , ft_fun = \g h x -> mkSimpleLam (\b -> h =<< (nlHsApp x `fmap` g b)) 
1323                                                                -- fmap f x = \b -> h (x (g b))
1324                  , ft_tup = mkSimpleTupleCase match_for_con    -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
1325                  , ft_ty_app = \_ g  x -> do gg <- mkSimpleLam g      -- fmap f x = fmap g x
1326                                              return $ nlHsApps fmap_RDR [gg,x]        
1327                  , ft_forall = \_ g  x -> g x
1328                  , ft_bad_app = panic "in other argument"
1329                  , ft_co_var = panic "contravariant" }
1330
1331     match_for_con = mkSimpleConMatch $
1332         \con_name xsM -> do xs <- sequence xsM
1333                             return (nlHsApps con_name xs)  -- Con (g1 v1) (g2 v2) ..
1334 \end{code}
1335
1336 Utility functions related to Functor deriving.
1337
1338 Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
1339 This function works like a fold: it makes a value of type 'a' in a bottom up way.
1340
1341 \begin{code}
1342 -- Generic traversal for Functor deriving
1343 data FFoldType a      -- Describes how to fold over a Type in a functor like way
1344    = FT { ft_triv    :: a                   -- Does not contain variable
1345         , ft_var     :: a                   -- The variable itself                             
1346         , ft_co_var  :: a                   -- The variable itself, contravariantly            
1347         , ft_fun     :: a -> a -> a         -- Function type
1348         , ft_tup     :: Boxity -> [a] -> a  -- Tuple type 
1349         , ft_ty_app  :: Type -> a -> a      -- Type app, variable only in last argument        
1350         , ft_bad_app :: a                   -- Type app, variable other than in last argument  
1351         , ft_forall  :: TcTyVar -> a -> a   -- Forall type                                     
1352      }
1353
1354 functorLikeTraverse :: TyVar         -- ^ Variable to look for
1355                     -> FFoldType a   -- ^ How to fold
1356                     -> Type          -- ^ Type to process
1357                     -> a
1358 functorLikeTraverse var (FT { ft_triv = caseTrivial,     ft_var = caseVar
1359                             , ft_co_var = caseCoVar,     ft_fun = caseFun
1360                             , ft_tup = caseTuple,        ft_ty_app = caseTyApp 
1361                             , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
1362                     ty
1363   = fst (go False ty)
1364   where -- go returns (result of type a, does type contain var)
1365         go co ty | Just ty' <- coreView ty = go co ty'
1366         go co (TyVarTy    v) | v == var = (if co then caseCoVar else caseVar,True)
1367         go co (FunTy (PredTy _) b)      = go co b
1368         go co (FunTy x y)    | xc || yc = (caseFun xr yr,True)
1369             where (xr,xc) = go (not co) x
1370                   (yr,yc) = go co       y
1371         go co (AppTy    x y) | xc = (caseWrongArg,   True)
1372                              | yc = (caseTyApp x yr, True)
1373             where (_, xc) = go co x
1374                   (yr,yc) = go co y
1375         go co ty@(TyConApp con args)
1376                | isTupleTyCon con = (caseTuple (tupleTyConBoxity con) xrs,True)
1377                | null args        = (caseTrivial,False)  -- T
1378                | or (init xcs)    = (caseWrongArg,True)  -- T (..var..)    ty
1379                | last xcs         =                      -- T (..no var..) ty
1380                                     (caseTyApp (fst (splitAppTy ty)) (last xrs),True)
1381             where (xrs,xcs) = unzip (map (go co) args)
1382         go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True)
1383             where (xr,xc) = go co x
1384         go _ _ = (caseTrivial,False)
1385
1386 -- Return all syntactic subterms of ty that contain var somewhere
1387 -- These are the things that should appear in instance constraints
1388 deepSubtypesContaining :: TyVar -> Type -> [TcType]
1389 deepSubtypesContaining tv
1390   = functorLikeTraverse tv 
1391         (FT { ft_triv = []
1392             , ft_var = []
1393             , ft_fun = (++), ft_tup = \_ xs -> concat xs
1394             , ft_ty_app = (:)
1395             , ft_bad_app = panic "in other argument"
1396             , ft_co_var = panic "contravariant"
1397             , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyVarsOfType) xs })
1398
1399
1400 foldDataConArgs :: FFoldType a -> DataCon -> [a]
1401 -- Fold over the arguments of the datacon
1402 foldDataConArgs ft con
1403   = map (functorLikeTraverse tv ft) (dataConOrigArgTys con)
1404   where
1405     tv = last (dataConUnivTyVars con) 
1406                     -- Argument to derive for, 'a in the above description
1407                     -- The validity checks have ensured that con is
1408                     -- a vanilla data constructor
1409
1410 -- Make a HsLam using a fresh variable from a State monad
1411 mkSimpleLam :: (LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1412 -- (mkSimpleLam fn) returns (\x. fn(x))
1413 mkSimpleLam lam = do
1414     (n:names) <- get
1415     put names
1416     body <- lam (nlHsVar n)
1417     return (mkHsLam [nlVarPat n] body)
1418
1419 mkSimpleLam2 :: (LHsExpr id -> LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1420 mkSimpleLam2 lam = do
1421     (n1:n2:names) <- get
1422     put names
1423     body <- lam (nlHsVar n1) (nlHsVar n2)
1424     return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
1425
1426 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
1427 mkSimpleConMatch :: Monad m => (RdrName -> [a] -> m (LHsExpr RdrName)) -> [LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName)
1428 mkSimpleConMatch fold extra_pats con insides = do
1429     let con_name = getRdrName con
1430     let vars_needed = takeList insides as_RDRs
1431     let pat = nlConVarPat con_name vars_needed
1432     rhs <- fold con_name (zipWith ($) insides (map nlHsVar vars_needed))
1433     return $ mkMatch (extra_pats ++ [pat]) rhs emptyLocalBinds
1434
1435 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
1436 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName))
1437                   -> Boxity -> [LHsExpr RdrName -> a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
1438 mkSimpleTupleCase match_for_con boxity insides x = do
1439     let con = tupleCon boxity (length insides)
1440     match <- match_for_con [] con insides
1441     return $ nlHsCase x [match]
1442 \end{code}
1443
1444
1445 %************************************************************************
1446 %*                                                                      *
1447                         Foldable instances
1448
1449  see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1450
1451 %*                                                                      *
1452 %************************************************************************
1453
1454 Deriving Foldable instances works the same way as Functor instances,
1455 only Foldable instances are not possible for function types at all.
1456 Here the derived instance for the type T above is:
1457
1458   instance Foldable T where
1459       foldr f z (T1 x1 x2 x3) = $(foldr 'a 'b1) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a 'b2) x3 z ) )
1460
1461 The cases are:
1462
1463   $(foldr 'a 'b)         x z  =  z     -- when b does not contain a
1464   $(foldr 'a 'a)         x z  =  f x z
1465   $(foldr 'a '(b1,b2))   x z  =  case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
1466   $(foldr 'a '(T b1 b2)) x z  =  foldr $(foldr 'a 'b2) x z  -- when a only occurs in the last parameter, b2
1467
1468 Note that the arguments to the real foldr function are the wrong way around,
1469 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
1470
1471 \begin{code}
1472 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1473 gen_Foldable_binds loc tycon
1474   = (unitBag foldr_bind, [])
1475   where
1476     data_cons = tyConDataCons tycon
1477
1478     foldr_bind = L loc $ mkFunBind (L loc foldable_foldr_RDR) (map foldr_eqn data_cons)
1479     foldr_eqn con = evalState (match_for_con z_Expr [f_Pat,z_Pat] con parts) bs_RDRs
1480       where 
1481         parts = foldDataConArgs ft_foldr con
1482
1483     ft_foldr :: FFoldType (LHsExpr RdrName -> LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1484     ft_foldr = FT { ft_triv = \_ z -> return z                        -- foldr f z x = z
1485                   , ft_var  = \x z -> return (nlHsApps f_RDR [x,z])   -- foldr f z x = f x z
1486                   , ft_tup = \b gs x z -> mkSimpleTupleCase (match_for_con z) b gs x
1487                   , ft_ty_app = \_ g  x z -> do gg <- mkSimpleLam2 g   -- foldr f z x = foldr (\xx zz -> g xx zz) z x
1488                                                 return $ nlHsApps foldable_foldr_RDR [gg,z,x]
1489                   , ft_forall = \_ g  x z -> g x z
1490                   , ft_co_var = panic "covariant"
1491                   , ft_fun = panic "function"
1492                   , ft_bad_app = panic "in other argument" }
1493
1494     match_for_con z = mkSimpleConMatch (\_con_name -> foldrM ($) z) -- g1 v1 (g2 v2 (.. z))
1495 \end{code}
1496
1497
1498 %************************************************************************
1499 %*                                                                      *
1500                         Traversable instances
1501
1502  see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1503 %*                                                                      *
1504 %************************************************************************
1505
1506 Again, Traversable is much like Functor and Foldable.
1507
1508 The cases are:
1509
1510   $(traverse 'a 'b)         x  =  pure x     -- when b does not contain a
1511   $(traverse 'a 'a)         x  =  f x
1512   $(traverse 'a '(b1,b2))   x  =  case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
1513   $(traverse 'a '(T b1 b2)) x  =  traverse $(traverse 'a 'b2) x  -- when a only occurs in the last parameter, b2
1514
1515 Note that the generated code is not as efficient as it could be. For instance:
1516
1517   data T a = T Int a  deriving Traversable
1518
1519 gives the function: traverse f (T x y) = T <$> pure x <*> f y
1520 instead of:         traverse f (T x y) = T x <$> f y
1521
1522 \begin{code}
1523 gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1524 gen_Traversable_binds loc tycon
1525   = (unitBag traverse_bind, [])
1526   where
1527     data_cons = tyConDataCons tycon
1528
1529     traverse_bind = L loc $ mkFunBind (L loc traverse_RDR) (map traverse_eqn data_cons)
1530     traverse_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1531       where 
1532         parts = foldDataConArgs ft_trav con
1533
1534
1535     ft_trav :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1536     ft_trav = FT { ft_triv = \x -> return (nlHsApps pure_RDR [x])   -- traverse f x = pure x
1537                  , ft_var = \x -> return (nlHsApps f_RDR [x])       -- travese f x = f x
1538                  , ft_tup = mkSimpleTupleCase match_for_con         -- travese f x z = case x of (a1,a2,..) -> 
1539                                                                     --                   (,,) <$> g1 a1 <*> g2 a2 <*> ..
1540                  , ft_ty_app = \_ g  x -> do gg <- mkSimpleLam g    -- travese f x = travese (\xx -> g xx) x
1541                                              return $ nlHsApps traverse_RDR [gg,x]
1542                  , ft_forall = \_ g  x -> g x
1543                  , ft_co_var = panic "covariant"
1544                  , ft_fun = panic "function"
1545                  , ft_bad_app = panic "in other argument" }
1546
1547     match_for_con = mkSimpleConMatch $
1548         \con_name xsM -> do xs <- sequence xsM
1549                             return (mkApCon (nlHsVar con_name) xs)
1550
1551     -- ((Con <$> x1) <*> x2) <*> ..
1552     mkApCon con []     = nlHsApps pure_RDR [con]
1553     mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
1554        where appAp x y = nlHsApps ap_RDR [x,y]
1555 \end{code}
1556
1557
1558
1559 %************************************************************************
1560 %*                                                                      *
1561 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1562 %*                                                                      *
1563 %************************************************************************
1564
1565 \begin{verbatim}
1566 data Foo ... = ...
1567
1568 con2tag_Foo :: Foo ... -> Int#
1569 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
1570 maxtag_Foo  :: Int              -- ditto (NB: not unlifted)
1571 \end{verbatim}
1572
1573 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1574 fiddling around.
1575
1576 \begin{code}
1577 genAuxBind :: SrcSpan -> DerivAuxBind -> LHsBind RdrName
1578 genAuxBind loc (GenCon2Tag tycon)
1579   | lots_of_constructors
1580   = mk_FunBind loc rdr_name [([], get_tag_rhs)]
1581
1582   | otherwise
1583   = mk_FunBind loc rdr_name (map mk_stuff (tyConDataCons tycon))
1584
1585   where
1586     rdr_name = con2tag_RDR tycon
1587
1588     tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1589         -- We can't use gerRdrName because that makes an Exact  RdrName
1590         -- and we can't put them in the LocalRdrEnv
1591
1592         -- Give a signature to the bound variable, so 
1593         -- that the case expression generated by getTag is
1594         -- monomorphic.  In the push-enter model we get better code.
1595     get_tag_rhs = L loc $ ExprWithTySig 
1596                         (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR) 
1597                                               (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1598                         (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1599
1600     con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
1601                 `nlHsFunTy` 
1602                 nlHsTyVar (getRdrName intPrimTyCon)
1603
1604     lots_of_constructors = tyConFamilySize tycon > 8
1605                                 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1606                                 -- but we don't do vectored returns any more.
1607
1608     mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1609     mk_stuff con = ([nlWildConPat con], 
1610                     nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1611
1612 genAuxBind loc (GenTag2Con tycon)
1613   = mk_FunBind loc rdr_name 
1614         [([nlConVarPat intDataCon_RDR [a_RDR]], 
1615            noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr) 
1616                          (nlHsTyVar (getRdrName tycon))))]
1617   where
1618     rdr_name = tag2con_RDR tycon
1619
1620 genAuxBind loc (GenMaxTag tycon)
1621   = mkVarBind loc rdr_name 
1622                   (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1623   where
1624     rdr_name = maxtag_RDR tycon
1625     max_tag =  case (tyConDataCons tycon) of
1626                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1627
1628 genAuxBind loc (MkTyCon tycon)  --  $dT
1629   = mkVarBind loc (mk_data_type_name tycon)
1630                   ( nlHsVar mkDataType_RDR 
1631                     `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
1632                     `nlHsApp` nlList constrs )
1633   where
1634     constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
1635
1636 genAuxBind loc (MkDataCon dc)   --  $cT1 etc
1637   = mkVarBind loc (mk_constr_name dc) 
1638                   (nlHsApps mkConstr_RDR constr_args)
1639   where
1640     constr_args 
1641        = [ -- nlHsIntLit (toInteger (dataConTag dc)),     -- Tag
1642            nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
1643            nlHsLit (mkHsString (occNameString dc_occ)),   -- String name
1644            nlList  labels,                                -- Field labels
1645            nlHsVar fixity]                                -- Fixity
1646
1647     labels   = map (nlHsLit . mkHsString . getOccString)
1648                    (dataConFieldLabels dc)
1649     dc_occ   = getOccName dc
1650     is_infix = isDataSymOcc dc_occ
1651     fixity | is_infix  = infix_RDR
1652            | otherwise = prefix_RDR
1653
1654 mk_data_type_name :: TyCon -> RdrName   -- "$tT"
1655 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
1656
1657 mk_constr_name :: DataCon -> RdrName    -- "$cC"
1658 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
1659 \end{code}
1660
1661 %************************************************************************
1662 %*                                                                      *
1663 \subsection{Utility bits for generating bindings}
1664 %*                                                                      *
1665 %************************************************************************
1666
1667
1668 ToDo: Better SrcLocs.
1669
1670 \begin{code}
1671 compare_gen_Case ::
1672           LHsExpr RdrName       -- What to do for equality
1673           -> LHsExpr RdrName -> LHsExpr RdrName
1674           -> LHsExpr RdrName
1675 careful_compare_Case :: -- checks for primitive types...
1676           TyCon                 -- The tycon we are deriving for
1677           -> Type
1678           -> LHsExpr RdrName    -- What to do for equality
1679           -> LHsExpr RdrName -> LHsExpr RdrName
1680           -> LHsExpr RdrName
1681
1682 cmp_eq_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1683 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1684         -- Was: compare_gen_Case cmp_eq_RDR
1685
1686 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1687   = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case 
1688 compare_gen_Case eq a b                         -- General case
1689   = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1690       [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1691        mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1692        mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1693
1694 careful_compare_Case tycon ty eq a b
1695   | not (isUnLiftedType ty)
1696   = compare_gen_Case eq a b
1697   | otherwise      -- We have to do something special for primitive things...
1698   = nlHsIf (genOpApp a relevant_lt_op b)        -- Test (<) first, not (==), becuase the latter
1699            ltTag_Expr                           -- is true less often, so putting it first would
1700                                                 -- mean more tests (dynamically)
1701            (nlHsIf (genOpApp a relevant_eq_op b) eq gtTag_Expr)
1702   where
1703     relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1704     relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1705
1706
1707 box_if_necy :: String           -- The class involved
1708             -> TyCon            -- The tycon involved
1709             -> LHsExpr RdrName  -- The argument
1710             -> Type             -- The argument type
1711             -> LHsExpr RdrName  -- Boxed version of the arg
1712 box_if_necy cls_str tycon arg arg_ty
1713   | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1714   | otherwise             = arg
1715   where
1716     box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1717
1718 assoc_ty_id :: String           -- The class involved
1719             -> TyCon            -- The tycon involved
1720             -> [(Type,a)]       -- The table
1721             -> Type             -- The type
1722             -> a                -- The result of the lookup
1723 assoc_ty_id cls_str _ tbl ty 
1724   | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+> 
1725                                               text "for primitive type" <+> ppr ty)
1726   | otherwise = head res
1727   where
1728     res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1729
1730 eq_op_tbl :: [(Type, PrimOp)]
1731 eq_op_tbl =
1732     [(charPrimTy,       CharEqOp)
1733     ,(intPrimTy,        IntEqOp)
1734     ,(wordPrimTy,       WordEqOp)
1735     ,(addrPrimTy,       AddrEqOp)
1736     ,(floatPrimTy,      FloatEqOp)
1737     ,(doublePrimTy,     DoubleEqOp)
1738     ]
1739
1740 lt_op_tbl :: [(Type, PrimOp)]
1741 lt_op_tbl =
1742     [(charPrimTy,       CharLtOp)
1743     ,(intPrimTy,        IntLtOp)
1744     ,(wordPrimTy,       WordLtOp)
1745     ,(addrPrimTy,       AddrLtOp)
1746     ,(floatPrimTy,      FloatLtOp)
1747     ,(doublePrimTy,     DoubleLtOp)
1748     ]
1749
1750 box_con_tbl :: [(Type, RdrName)]
1751 box_con_tbl =
1752     [(charPrimTy,       getRdrName charDataCon)
1753     ,(intPrimTy,        getRdrName intDataCon)
1754     ,(wordPrimTy,       wordDataCon_RDR)
1755     ,(floatPrimTy,      getRdrName floatDataCon)
1756     ,(doublePrimTy,     getRdrName doubleDataCon)
1757     ]
1758
1759 -----------------------------------------------------------------------
1760
1761 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1762 and_Expr a b = genOpApp a and_RDR    b
1763
1764 -----------------------------------------------------------------------
1765
1766 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1767 eq_Expr tycon ty a b = genOpApp a eq_op b
1768  where
1769    eq_op
1770     | not (isUnLiftedType ty) = eq_RDR
1771     | otherwise               = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1772          -- we have to do something special for primitive things...
1773 \end{code}
1774
1775 \begin{code}
1776 untag_Expr :: TyCon -> [( RdrName,  RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1777 untag_Expr _ [] expr = expr
1778 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1779   = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1780       [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1781
1782 cmp_tags_Expr ::  RdrName               -- Comparison op
1783              ->  RdrName ->  RdrName    -- Things to compare
1784              -> LHsExpr RdrName                 -- What to return if true
1785              -> LHsExpr RdrName         -- What to return if false
1786              -> LHsExpr RdrName
1787
1788 cmp_tags_Expr op a b true_case false_case
1789   = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1790
1791 enum_from_to_Expr
1792         :: LHsExpr RdrName -> LHsExpr RdrName
1793         -> LHsExpr RdrName
1794 enum_from_then_to_Expr
1795         :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1796         -> LHsExpr RdrName
1797
1798 enum_from_to_Expr      f   t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1799 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1800
1801 showParen_Expr
1802         :: LHsExpr RdrName -> LHsExpr RdrName
1803         -> LHsExpr RdrName
1804
1805 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1806
1807 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1808
1809 nested_compose_Expr []  = panic "nested_compose_expr"   -- Arg is always non-empty
1810 nested_compose_Expr [e] = parenify e
1811 nested_compose_Expr (e:es)
1812   = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1813
1814 -- impossible_Expr is used in case RHSs that should never happen.
1815 -- We generate these to keep the desugarer from complaining that they *might* happen!
1816 impossible_Expr :: LHsExpr RdrName
1817 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1818
1819 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1820 -- method. It is currently only used by Enum.{succ,pred}
1821 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
1822 illegal_Expr meth tp msg = 
1823    nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1824
1825 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1826 -- to include the value of a_RDR in the error string.
1827 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
1828 illegal_toEnum_tag tp maxtag =
1829    nlHsApp (nlHsVar error_RDR) 
1830            (nlHsApp (nlHsApp (nlHsVar append_RDR)
1831                        (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1832                     (nlHsApp (nlHsApp (nlHsApp 
1833                            (nlHsVar showsPrec_RDR)
1834                            (nlHsIntLit 0))
1835                            (nlHsVar a_RDR))
1836                            (nlHsApp (nlHsApp 
1837                                (nlHsVar append_RDR)
1838                                (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1839                                (nlHsApp (nlHsApp (nlHsApp 
1840                                         (nlHsVar showsPrec_RDR)
1841                                         (nlHsIntLit 0))
1842                                         (nlHsVar maxtag))
1843                                         (nlHsLit (mkHsString ")"))))))
1844
1845 parenify :: LHsExpr RdrName -> LHsExpr RdrName
1846 parenify e@(L _ (HsVar _)) = e
1847 parenify e                 = mkHsPar e
1848
1849 -- genOpApp wraps brackets round the operator application, so that the
1850 -- renamer won't subsequently try to re-associate it. 
1851 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1852 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1853 \end{code}
1854
1855 \begin{code}
1856 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR,
1857     cmp_eq_RDR :: RdrName
1858 a_RDR           = mkVarUnqual (fsLit "a")
1859 b_RDR           = mkVarUnqual (fsLit "b")
1860 c_RDR           = mkVarUnqual (fsLit "c")
1861 d_RDR           = mkVarUnqual (fsLit "d")
1862 f_RDR           = mkVarUnqual (fsLit "f")
1863 k_RDR           = mkVarUnqual (fsLit "k")
1864 z_RDR           = mkVarUnqual (fsLit "z")
1865 ah_RDR          = mkVarUnqual (fsLit "a#")
1866 bh_RDR          = mkVarUnqual (fsLit "b#")
1867 ch_RDR          = mkVarUnqual (fsLit "c#")
1868 dh_RDR          = mkVarUnqual (fsLit "d#")
1869 cmp_eq_RDR      = mkVarUnqual (fsLit "cmp_eq")
1870
1871 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
1872 as_RDRs         = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1873 bs_RDRs         = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1874 cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1875
1876 a_Expr, b_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
1877     false_Expr, true_Expr :: LHsExpr RdrName
1878 a_Expr          = nlHsVar a_RDR
1879 b_Expr          = nlHsVar b_RDR
1880 c_Expr          = nlHsVar c_RDR
1881 f_Expr          = nlHsVar f_RDR
1882 z_Expr          = nlHsVar z_RDR
1883 ltTag_Expr      = nlHsVar ltTag_RDR
1884 eqTag_Expr      = nlHsVar eqTag_RDR
1885 gtTag_Expr      = nlHsVar gtTag_RDR
1886 false_Expr      = nlHsVar false_RDR
1887 true_Expr       = nlHsVar true_RDR
1888
1889 a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName
1890 a_Pat           = nlVarPat a_RDR
1891 b_Pat           = nlVarPat b_RDR
1892 c_Pat           = nlVarPat c_RDR
1893 d_Pat           = nlVarPat d_RDR
1894 f_Pat           = nlVarPat f_RDR
1895 k_Pat           = nlVarPat k_RDR
1896 z_Pat           = nlVarPat z_RDR
1897
1898 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1899 -- Generates Orig s RdrName, for the binding positions
1900 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
1901 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
1902 maxtag_RDR  tycon = mk_tc_deriv_name tycon mkMaxTagOcc
1903
1904 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
1905 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
1906
1907 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
1908 mkAuxBinderName parent occ_fun = mkRdrUnqual (occ_fun (nameOccName parent))
1909 -- Was: mkDerivedRdrName name occ_fun, which made an original name
1910 -- But:  (a) that does not work well for standalone-deriving
1911 --       (b) an unqualified name is just fine, provided it can't clash with user code
1912 \end{code}
1913
1914 s RdrName for PrimOps.  Can't be done in PrelNames, because PrimOp imports
1915 PrelNames, so PrelNames can't import PrimOp.
1916
1917 \begin{code}
1918 primOpRdrName :: PrimOp -> RdrName
1919 primOpRdrName op = getRdrName (primOpId op)
1920
1921 minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, leInt_RDR,
1922     tagToEnum_RDR :: RdrName
1923 minusInt_RDR  = primOpRdrName IntSubOp
1924 eqInt_RDR     = primOpRdrName IntEqOp
1925 ltInt_RDR     = primOpRdrName IntLtOp
1926 geInt_RDR     = primOpRdrName IntGeOp
1927 leInt_RDR     = primOpRdrName IntLeOp
1928 tagToEnum_RDR = primOpRdrName TagToEnumOp
1929
1930 error_RDR :: RdrName
1931 error_RDR = getRdrName eRROR_ID
1932 \end{code}