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