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