77bda8274bd38ce3d89dfcd0f709a6e13638bc86
[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                     (genOpApp (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 (genOpApp (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 (genOpApp (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 = genOpApp a_expr (primOpRdrName prim_op) b_expr
481    a_expr = nlHsVar a
482    b_expr = nlHsVar b
483
484 unliftedCompare :: PrimOp -> PrimOp
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 (genOpApp a_expr (primOpRdrName 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 (genOpApp a_expr (primOpRdrName 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 (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
758              (genOpApp (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 :: RdrName
1446 gfoldl_RDR     = varQual_RDR  gENERICS (fsLit "gfoldl")
1447 gunfold_RDR    = varQual_RDR  gENERICS (fsLit "gunfold")
1448 toConstr_RDR   = varQual_RDR  gENERICS (fsLit "toConstr")
1449 dataTypeOf_RDR = varQual_RDR  gENERICS (fsLit "dataTypeOf")
1450 dataCast1_RDR  = varQual_RDR  gENERICS (fsLit "dataCast1")
1451 dataCast2_RDR  = varQual_RDR  gENERICS (fsLit "dataCast2")
1452 gcast1_RDR     = varQual_RDR  tYPEABLE (fsLit "gcast1")
1453 gcast2_RDR     = varQual_RDR  tYPEABLE (fsLit "gcast2")
1454 mkConstr_RDR   = varQual_RDR  gENERICS (fsLit "mkConstr")
1455 constr_RDR     = tcQual_RDR   gENERICS (fsLit "Constr")
1456 mkDataType_RDR = varQual_RDR  gENERICS (fsLit "mkDataType")
1457 dataType_RDR   = tcQual_RDR   gENERICS (fsLit "DataType")
1458 conIndex_RDR   = varQual_RDR  gENERICS (fsLit "constrIndex")
1459 prefix_RDR     = dataQual_RDR gENERICS (fsLit "Prefix")
1460 infix_RDR      = dataQual_RDR gENERICS (fsLit "Infix")
1461 \end{code}
1462
1463
1464
1465 %************************************************************************
1466 %*                                                                      *
1467                         Functor instances
1468
1469  see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1470
1471 %*                                                                      *
1472 %************************************************************************
1473
1474 For the data type:
1475
1476   data T a = T1 Int a | T2 (T a)
1477
1478 We generate the instance:
1479
1480   instance Functor T where
1481       fmap f (T1 b1 a) = T1 b1 (f a)
1482       fmap f (T2 ta)   = T2 (fmap f ta)
1483
1484 Notice that we don't simply apply 'fmap' to the constructor arguments.
1485 Rather
1486   - Do nothing to an argument whose type doesn't mention 'a'
1487   - Apply 'f' to an argument of type 'a'
1488   - Apply 'fmap f' to other arguments
1489 That's why we have to recurse deeply into the constructor argument types,
1490 rather than just one level, as we typically do.
1491
1492 What about types with more than one type parameter?  In general, we only
1493 derive Functor for the last position:
1494
1495   data S a b = S1 [b] | S2 (a, T a b)
1496   instance Functor (S a) where
1497     fmap f (S1 bs)    = S1 (fmap f bs)
1498     fmap f (S2 (p,q)) = S2 (a, fmap f q)
1499
1500 However, we have special cases for
1501          - tuples
1502          - functions
1503
1504 More formally, we write the derivation of fmap code over type variable
1505 'a for type 'b as ($fmap 'a 'b).  In this general notation the derived
1506 instance for T is:
1507
1508   instance Functor T where
1509       fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
1510       fmap f (T2 x1)    = T2 ($(fmap 'a '(T a)) x1)
1511
1512   $(fmap 'a 'b)          =  \x -> x     -- when b does not contain a
1513   $(fmap 'a 'a)          =  f
1514   $(fmap 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
1515   $(fmap 'a '(T b1 b2))  =  fmap $(fmap 'a 'b2)   -- when a only occurs in the last parameter, b2
1516   $(fmap 'a '(b -> c))   =  \x b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
1517
1518 For functions, the type parameter 'a can occur in a contravariant position,
1519 which means we need to derive a function like:
1520
1521   cofmap :: (a -> b) -> (f b -> f a)
1522
1523 This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
1524
1525   $(cofmap 'a 'b)          =  \x -> x     -- when b does not contain a
1526   $(cofmap 'a 'a)          =  error "type variable in contravariant position"
1527   $(cofmap 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
1528   $(cofmap 'a '[b])        =  map $(cofmap 'a 'b)
1529   $(cofmap 'a '(T b1 b2))  =  fmap $(cofmap 'a 'b2)   -- when a only occurs in the last parameter, b2
1530   $(cofmap 'a '(b -> c))   =  \x b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
1531
1532 Note that the code produced by $(fmap _ _) is always a higher order function,
1533 with type `(a -> b) -> (g a -> g b)` for some g. When we need to do pattern
1534 matching on the type, this means create a lambda function (see the (,) case above).
1535 The resulting code for fmap can look a bit weird, for example:
1536
1537   data X a = X (a,Int)
1538   -- generated instance
1539   instance Functor X where
1540       fmap f (X x) = (\y -> case y of (x1,x2) -> X (f x1, (\z -> z) x2)) x
1541
1542 The optimizer should be able to simplify this code by simple inlining.
1543
1544 An older version of the deriving code tried to avoid these applied
1545 lambda functions by producing a meta level function. But the function to
1546 be mapped, `f`, is a function on the code level, not on the meta level,
1547 so it was eta expanded to `\x -> [| f $x |]`. This resulted in too much eta expansion.
1548 It is better to produce too many lambdas than to eta expand, see ticket #7436.
1549
1550 \begin{code}
1551 gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1552 gen_Functor_binds loc tycon
1553   = (unitBag fmap_bind, emptyBag)
1554   where
1555     data_cons = tyConDataCons tycon
1556     fmap_bind = L loc $ mkRdrFunBind (L loc fmap_RDR) eqns
1557
1558     fmap_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
1559       where
1560         parts = sequence $ foldDataConArgs ft_fmap con
1561
1562     eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat]
1563                                            (error_Expr "Void fmap")]
1564          | otherwise      = map fmap_eqn data_cons
1565
1566     ft_fmap :: FFoldType (State [RdrName] (LHsExpr RdrName))
1567     ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x    -- fmap f = \x -> x
1568                  , ft_var  = return f_Expr                   -- fmap f = f
1569                  , ft_fun  = \g h -> do                      -- fmap f = \x b -> h (x (g b))
1570                                  gg <- g
1571                                  hh <- h
1572                                  mkSimpleLam2 $ \x b -> return $ nlHsApp hh (nlHsApp x (nlHsApp gg b)) 
1573                  , ft_tup = \t gs -> do                      -- fmap f = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
1574                                  gg <- sequence gs
1575                                  mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
1576                  , ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g  -- fmap f = fmap g
1577                  , ft_forall = \_ g -> g
1578                  , ft_bad_app = panic "in other argument"
1579                  , ft_co_var = panic "contravariant" }
1580
1581     -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
1582     match_for_con :: [LPat RdrName] -> DataCon -> [LHsExpr RdrName]
1583                   -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
1584     match_for_con = mkSimpleConMatch $
1585         \con_name xs -> return $ nlHsApps con_name xs  -- Con x1 x2 ..
1586 \end{code}
1587
1588 Utility functions related to Functor deriving.
1589
1590 Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
1591 This function works like a fold: it makes a value of type 'a' in a bottom up way.
1592
1593 \begin{code}
1594 -- Generic traversal for Functor deriving
1595 data FFoldType a      -- Describes how to fold over a Type in a functor like way
1596    = FT { ft_triv    :: a                   -- Does not contain variable
1597         , ft_var     :: a                   -- The variable itself
1598         , ft_co_var  :: a                   -- The variable itself, contravariantly
1599         , ft_fun     :: a -> a -> a         -- Function type
1600         , ft_tup     :: TupleSort -> [a] -> a  -- Tuple type
1601         , ft_ty_app  :: Type -> a -> a      -- Type app, variable only in last argument
1602         , ft_bad_app :: a                   -- Type app, variable other than in last argument
1603         , ft_forall  :: TcTyVar -> a -> a   -- Forall type
1604      }
1605
1606 functorLikeTraverse :: forall a.
1607                        TyVar         -- ^ Variable to look for
1608                     -> FFoldType a   -- ^ How to fold
1609                     -> Type          -- ^ Type to process
1610                     -> a
1611 functorLikeTraverse var (FT { ft_triv = caseTrivial,     ft_var = caseVar
1612                             , ft_co_var = caseCoVar,     ft_fun = caseFun
1613                             , ft_tup = caseTuple,        ft_ty_app = caseTyApp
1614                             , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
1615                     ty
1616   = fst (go False ty)
1617   where
1618     go :: Bool        -- Covariant or contravariant context
1619        -> Type
1620        -> (a, Bool)   -- (result of type a, does type contain var)
1621
1622     go co ty | Just ty' <- coreView ty = go co ty'
1623     go co (TyVarTy    v) | v == var = (if co then caseCoVar else caseVar,True)
1624     go co (FunTy x y)  | isPredTy x = go co y
1625                        | xc || yc   = (caseFun xr yr,True)
1626         where (xr,xc) = go (not co) x
1627               (yr,yc) = go co       y
1628     go co (AppTy    x y) | xc = (caseWrongArg,   True)
1629                          | yc = (caseTyApp x yr, True)
1630         where (_, xc) = go co x
1631               (yr,yc) = go co y
1632     go co ty@(TyConApp con args)
1633        | not (or xcs)     = (caseTrivial, False)   -- Variable does not occur
1634        -- At this point we know that xrs, xcs is not empty,
1635        -- and at least one xr is True
1636        | isTupleTyCon con = (caseTuple (tupleTyConSort con) xrs, True)
1637        | or (init xcs)    = (caseWrongArg, True)         -- T (..var..)    ty
1638        | otherwise        = case splitAppTy_maybe ty of  -- T (..no var..) ty
1639                               Nothing -> (caseWrongArg, True)   -- Non-decomposable (eg type function)
1640                               Just (fun_ty, _) -> (caseTyApp fun_ty (last xrs), True)
1641        where
1642          (xrs,xcs) = unzip (map (go co) args)
1643     go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True)
1644         where (xr,xc) = go co x
1645     go _ _ = (caseTrivial,False)
1646
1647 -- Return all syntactic subterms of ty that contain var somewhere
1648 -- These are the things that should appear in instance constraints
1649 deepSubtypesContaining :: TyVar -> Type -> [TcType]
1650 deepSubtypesContaining tv
1651   = functorLikeTraverse tv
1652         (FT { ft_triv = []
1653             , ft_var = []
1654             , ft_fun = (++)
1655             , ft_tup = \_ xs -> concat xs
1656             , ft_ty_app = (:)
1657             , ft_bad_app = panic "in other argument"
1658             , ft_co_var = panic "contravariant"
1659             , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyVarsOfType) xs })
1660
1661
1662 foldDataConArgs :: FFoldType a -> DataCon -> [a]
1663 -- Fold over the arguments of the datacon
1664 foldDataConArgs ft con
1665   = map (functorLikeTraverse tv ft) (dataConOrigArgTys con)
1666   where
1667     tv = last (dataConUnivTyVars con)
1668                     -- Argument to derive for, 'a in the above description
1669                     -- The validity checks have ensured that con is
1670                     -- a vanilla data constructor
1671
1672 -- Make a HsLam using a fresh variable from a State monad
1673 mkSimpleLam :: (LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1674 -- (mkSimpleLam fn) returns (\x. fn(x))
1675 mkSimpleLam lam = do
1676     (n:names) <- get
1677     put names
1678     body <- lam (nlHsVar n)
1679     return (mkHsLam [nlVarPat n] body)
1680
1681 mkSimpleLam2 :: (LHsExpr id -> LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1682 mkSimpleLam2 lam = do
1683     (n1:n2:names) <- get
1684     put names
1685     body <- lam (nlHsVar n1) (nlHsVar n2)
1686     return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
1687
1688 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
1689 mkSimpleConMatch :: Monad m => (RdrName -> [LHsExpr RdrName] -> m (LHsExpr RdrName))
1690                  -> [LPat RdrName]
1691                  -> DataCon
1692                  -> [LHsExpr RdrName]
1693                  -> m (LMatch RdrName (LHsExpr RdrName))
1694 mkSimpleConMatch fold extra_pats con insides = do
1695     let con_name = getRdrName con
1696     let vars_needed = takeList insides as_RDRs
1697     let pat = nlConVarPat con_name vars_needed
1698     rhs <- fold con_name (zipWith nlHsApp insides (map nlHsVar vars_needed))
1699     return $ mkMatch (extra_pats ++ [pat]) rhs emptyLocalBinds
1700
1701 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
1702 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [a]
1703                                  -> m (LMatch RdrName (LHsExpr RdrName)))
1704                   -> TupleSort -> [a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
1705 mkSimpleTupleCase match_for_con sort insides x = do
1706     let con = tupleCon sort (length insides)
1707     match <- match_for_con [] con insides
1708     return $ nlHsCase x [match]
1709 \end{code}
1710
1711
1712 %************************************************************************
1713 %*                                                                      *
1714                         Foldable instances
1715
1716  see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1717
1718 %*                                                                      *
1719 %************************************************************************
1720
1721 Deriving Foldable instances works the same way as Functor instances,
1722 only Foldable instances are not possible for function types at all.
1723 Here the derived instance for the type T above is:
1724
1725   instance Foldable T where
1726       foldr f z (T1 x1 x2 x3) = $(foldr 'a 'b1) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a 'b2) x3 z ) )
1727
1728 The cases are:
1729
1730   $(foldr 'a 'b)         =  \x z -> z     -- when b does not contain a
1731   $(foldr 'a 'a)         =  f
1732   $(foldr 'a '(b1,b2))   =  \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
1733   $(foldr 'a '(T b1 b2)) =  \x z -> foldr $(foldr 'a 'b2) z x  -- when a only occurs in the last parameter, b2
1734
1735 Note that the arguments to the real foldr function are the wrong way around,
1736 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
1737
1738 \begin{code}
1739 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1740 gen_Foldable_binds loc tycon
1741   = (listToBag [foldr_bind, foldMap_bind], emptyBag)
1742   where
1743     data_cons = tyConDataCons tycon
1744
1745     foldr_bind = L loc $ mkRdrFunBind (L loc foldable_foldr_RDR) eqns
1746     eqns = map foldr_eqn data_cons
1747     foldr_eqn con = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs
1748       where
1749         parts = sequence $ foldDataConArgs ft_foldr con
1750
1751     foldMap_bind = L loc $ mkRdrFunBind (L loc foldMap_RDR) (map foldMap_eqn data_cons)
1752     foldMap_eqn con = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs
1753       where
1754         parts = sequence $ foldDataConArgs ft_foldMap con
1755
1756     ft_foldr :: FFoldType (State [RdrName] (LHsExpr RdrName))
1757     ft_foldr = FT { ft_triv    = mkSimpleLam2 $ \_ z -> return z       -- foldr f = \x z -> z
1758                   , ft_var     = return f_Expr                         -- foldr f = f
1759                   , ft_tup     = \t g -> do gg <- sequence g           -- foldr f = (\x z -> case x of ...)
1760                                             mkSimpleLam2 $ \x z -> mkSimpleTupleCase (match_foldr z) t gg x
1761                   , ft_ty_app  = \_ g -> do gg <- g                    -- foldr f = (\x z -> foldr g z x)
1762                                             mkSimpleLam2 $ \x z -> return $ nlHsApps foldable_foldr_RDR [gg,z,x]
1763                   , ft_forall  = \_ g -> g
1764                   , ft_co_var  = panic "contravariant"
1765                   , ft_fun     = panic "function"
1766                   , ft_bad_app = panic "in other argument" }
1767
1768     match_foldr z = mkSimpleConMatch $ \_con_name xs -> return $ foldr nlHsApp z xs -- g1 v1 (g2 v2 (.. z))
1769
1770     ft_foldMap :: FFoldType (State [RdrName] (LHsExpr RdrName))
1771     ft_foldMap = FT { ft_triv = mkSimpleLam $ \_ -> return mempty_Expr  -- foldMap f = \x -> mempty
1772                     , ft_var  = return f_Expr                           -- foldMap f = f
1773                     , ft_tup  = \t g -> do gg <- sequence g             -- foldMap f = \x -> case x of (..,)
1774                                            mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg
1775                     , ft_ty_app = \_ g -> nlHsApp foldMap_Expr <$> g    -- foldMap f = foldMap g
1776                     , ft_forall = \_ g -> g
1777                     , ft_co_var = panic "contravariant"
1778                     , ft_fun = panic "function"
1779                     , ft_bad_app = panic "in other argument" }
1780     
1781     match_foldMap = mkSimpleConMatch $ \_con_name xs -> return $
1782         case xs of
1783             [] -> mempty_Expr
1784             xs -> foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs
1785
1786 \end{code}
1787
1788
1789 %************************************************************************
1790 %*                                                                      *
1791                         Traversable instances
1792
1793  see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1794 %*                                                                      *
1795 %************************************************************************
1796
1797 Again, Traversable is much like Functor and Foldable.
1798
1799 The cases are:
1800
1801   $(traverse 'a 'b)          =  pure     -- when b does not contain a
1802   $(traverse 'a 'a)          =  f
1803   $(traverse 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
1804   $(traverse 'a '(T b1 b2))  =  traverse $(traverse 'a 'b2)  -- when a only occurs in the last parameter, b2
1805
1806 Note that the generated code is not as efficient as it could be. For instance:
1807
1808   data T a = T Int a  deriving Traversable
1809
1810 gives the function: traverse f (T x y) = T <$> pure x <*> f y
1811 instead of:         traverse f (T x y) = T x <$> f y
1812
1813 \begin{code}
1814 gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1815 gen_Traversable_binds loc tycon
1816   = (unitBag traverse_bind, emptyBag)
1817   where
1818     data_cons = tyConDataCons tycon
1819
1820     traverse_bind = L loc $ mkRdrFunBind (L loc traverse_RDR) eqns
1821     eqns = map traverse_eqn data_cons
1822     traverse_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
1823       where
1824         parts = sequence $ foldDataConArgs ft_trav con
1825
1826
1827     ft_trav :: FFoldType (State [RdrName] (LHsExpr RdrName))
1828     ft_trav = FT { ft_triv    = return pure_Expr                  -- traverse f = pure x
1829                  , ft_var     = return f_Expr                     -- traverse f = f x
1830                  , ft_tup     = \t gs -> do                       -- traverse f = \x -> case x of (a1,a2,..) ->
1831                                     gg <- sequence gs             --                   (,,) <$> g1 a1 <*> g2 a2 <*> ..
1832                                     mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
1833                  , ft_ty_app  = \_ g -> nlHsApp traverse_Expr <$> g  -- traverse f = travese g
1834                  , ft_forall  = \_ g -> g
1835                  , ft_co_var  = panic "contravariant"
1836                  , ft_fun     = panic "function"
1837                  , ft_bad_app = panic "in other argument" }
1838
1839     -- Con a1 a2 ... -> Con <$> g1 a1 <*> g2 a2 <*> ...
1840     match_for_con = mkSimpleConMatch $
1841         \con_name xs -> return $ mkApCon (nlHsVar con_name) xs
1842
1843     -- ((Con <$> x1) <*> x2) <*> ..
1844     mkApCon con []     = nlHsApps pure_RDR [con]
1845     mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
1846        where appAp x y = nlHsApps ap_RDR [x,y]
1847 \end{code}
1848
1849
1850
1851 %************************************************************************
1852 %*                                                                      *
1853 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1854 %*                                                                      *
1855 %************************************************************************
1856
1857 \begin{verbatim}
1858 data Foo ... = ...
1859
1860 con2tag_Foo :: Foo ... -> Int#
1861 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
1862 maxtag_Foo  :: Int              -- ditto (NB: not unlifted)
1863 \end{verbatim}
1864
1865 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1866 fiddling around.
1867
1868 \begin{code}
1869 genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName)
1870 genAuxBindSpec loc (DerivCon2Tag tycon)
1871   = (mk_FunBind loc rdr_name eqns,
1872      L loc (TypeSig [L loc rdr_name] (L loc sig_ty)))
1873   where
1874     rdr_name = con2tag_RDR tycon
1875
1876     sig_ty = HsCoreTy $
1877              mkSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
1878              mkParentType tycon `mkFunTy` intPrimTy
1879
1880     lots_of_constructors = tyConFamilySize tycon > 8
1881                         -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1882                         -- but we don't do vectored returns any more.
1883
1884     eqns | lots_of_constructors = [get_tag_eqn]
1885          | otherwise = map mk_eqn (tyConDataCons tycon)
1886
1887     get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
1888
1889     mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1890     mk_eqn con = ([nlWildConPat con],
1891                   nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1892
1893 genAuxBindSpec loc (DerivTag2Con tycon)
1894   = (mk_FunBind loc rdr_name
1895         [([nlConVarPat intDataCon_RDR [a_RDR]],
1896            nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
1897      L loc (TypeSig [L loc rdr_name] (L loc sig_ty)))
1898   where
1899     sig_ty = HsCoreTy $ mkForAllTys (tyConTyVars tycon) $
1900              intTy `mkFunTy` mkParentType tycon
1901
1902     rdr_name = tag2con_RDR tycon
1903
1904 genAuxBindSpec loc (DerivMaxTag tycon)
1905   = (mkHsVarBind loc rdr_name rhs,
1906      L loc (TypeSig [L loc rdr_name] (L loc sig_ty)))
1907   where
1908     rdr_name = maxtag_RDR tycon
1909     sig_ty = HsCoreTy intTy
1910     rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag))
1911     max_tag =  case (tyConDataCons tycon) of
1912                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1913
1914 type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings
1915                               ( Bag (LHsBind RdrName, LSig RdrName)
1916                                 -- Extra bindings (used by Generic only)
1917                               , Bag TyCon   -- Extra top-level datatypes
1918                               , Bag (FamInst)           -- Extra family instances
1919                               , Bag (InstInfo RdrName)) -- Extra instances
1920
1921 genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
1922 genAuxBinds loc b = genAuxBinds' b2 where
1923   (b1,b2) = partitionBagWith splitDerivAuxBind b
1924   splitDerivAuxBind (DerivAuxBind x) = Left x
1925   splitDerivAuxBind  x               = Right x
1926
1927   rm_dups = foldrBag dup_check emptyBag
1928   dup_check a b = if anyBag (== a) b then b else consBag a b
1929
1930   genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
1931   genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec loc) (rm_dups b1)
1932                             , emptyBag, emptyBag, emptyBag)
1933   f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
1934   f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
1935   f (DerivHsBind  b) = add1 b
1936   f (DerivTyCon   t) = add2 t
1937   f (DerivFamInst t) = add3 t
1938   f (DerivInst    i) = add4 i
1939
1940   add1 x (a,b,c,d) = (x `consBag` a,b,c,d)
1941   add2 x (a,b,c,d) = (a,x `consBag` b,c,d)
1942   add3 x (a,b,c,d) = (a,b,x `consBag` c,d)
1943   add4 x (a,b,c,d) = (a,b,c,x `consBag` d)
1944
1945 mk_data_type_name :: TyCon -> RdrName   -- "$tT"
1946 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
1947
1948 mk_constr_name :: DataCon -> RdrName    -- "$cC"
1949 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
1950
1951 mkParentType :: TyCon -> Type
1952 -- Turn the representation tycon of a family into
1953 -- a use of its family constructor
1954 mkParentType tc
1955   = case tyConFamInst_maybe tc of
1956        Nothing  -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
1957        Just (fam_tc,tys) -> mkTyConApp fam_tc tys
1958 \end{code}
1959
1960 %************************************************************************
1961 %*                                                                      *
1962 \subsection{Utility bits for generating bindings}
1963 %*                                                                      *
1964 %************************************************************************
1965
1966
1967 \begin{code}
1968 mk_FunBind :: SrcSpan -> RdrName
1969            -> [([LPat RdrName], LHsExpr RdrName)]
1970            -> LHsBind RdrName
1971 mk_FunBind loc fun pats_and_exprs
1972   = L loc $ mkRdrFunBind (L loc fun) matches
1973   where
1974     matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
1975
1976 mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> HsBind RdrName
1977 mkRdrFunBind fun@(L _ fun_rdr) matches
1978  | null matches = mkFunBind fun [mkMatch [] (error_Expr str) emptyLocalBinds]
1979         -- Catch-all eqn looks like
1980         --     fmap = error "Void fmap"
1981         -- It's needed if there no data cons at all,
1982         -- which can happen with -XEmptyDataDecls
1983         -- See Trac #4302
1984  | otherwise    = mkFunBind fun matches
1985  where
1986    str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
1987 \end{code}
1988
1989 \begin{code}
1990 box_if_necy :: String           -- The class involved
1991             -> TyCon            -- The tycon involved
1992             -> LHsExpr RdrName  -- The argument
1993             -> Type             -- The argument type
1994             -> LHsExpr RdrName  -- Boxed version of the arg
1995 -- See Note [Deriving and unboxed types]
1996 box_if_necy cls_str tycon arg arg_ty
1997   | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1998   | otherwise             = arg
1999   where
2000     box_con = assoc_ty_id cls_str tycon boxConTbl arg_ty
2001
2002 ---------------------
2003 primOrdOps :: String    -- The class involved
2004            -> TyCon     -- The tycon involved
2005            -> Type      -- The type
2006            -> (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp)  -- (lt,le,eq,ge,gt)
2007 -- See Note [Deriving and unboxed types]
2008 primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty
2009
2010 ordOpTbl :: [(Type, (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp))]
2011 ordOpTbl
2012  =  [(charPrimTy,       (CharLtOp,   CharLeOp,   CharEqOp,   CharGeOp,   CharGtOp))
2013     ,(intPrimTy,        (IntLtOp,    IntLeOp,    IntEqOp,    IntGeOp,    IntGtOp))
2014     ,(wordPrimTy,       (WordLtOp,   WordLeOp,   WordEqOp,   WordGeOp,   WordGtOp))
2015     ,(addrPrimTy,       (AddrLtOp,   AddrLeOp,   AddrEqOp,   AddrGeOp,   AddrGtOp))
2016     ,(floatPrimTy,      (FloatLtOp,  FloatLeOp,  FloatEqOp,  FloatGeOp,  FloatGtOp))
2017     ,(doublePrimTy,     (DoubleLtOp, DoubleLeOp, DoubleEqOp, DoubleGeOp, DoubleGtOp)) ]
2018
2019 boxConTbl :: [(Type, RdrName)]
2020 boxConTbl
2021   = [(charPrimTy,       getRdrName charDataCon)
2022     ,(intPrimTy,        getRdrName intDataCon)
2023     ,(wordPrimTy,       wordDataCon_RDR)
2024     ,(floatPrimTy,      getRdrName floatDataCon)
2025     ,(doublePrimTy,     getRdrName doubleDataCon)
2026     ]
2027
2028 assoc_ty_id :: String           -- The class involved
2029             -> TyCon            -- The tycon involved
2030             -> [(Type,a)]       -- The table
2031             -> Type             -- The type
2032             -> a                -- The result of the lookup
2033 assoc_ty_id cls_str _ tbl ty
2034   | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
2035                                               text "for primitive type" <+> ppr ty)
2036   | otherwise = head res
2037   where
2038     res = [id | (ty',id) <- tbl, ty `eqType` ty']
2039
2040 -----------------------------------------------------------------------
2041
2042 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2043 and_Expr a b = genOpApp a and_RDR    b
2044
2045 -----------------------------------------------------------------------
2046
2047 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2048 eq_Expr tycon ty a b = genOpApp a eq_op b
2049  where
2050    eq_op | not (isUnLiftedType ty) = eq_RDR
2051          | otherwise               = primOpRdrName prim_eq
2052    (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
2053 \end{code}
2054
2055 \begin{code}
2056 untag_Expr :: TyCon -> [( RdrName,  RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
2057 untag_Expr _ [] expr = expr
2058 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
2059   = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
2060       [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
2061
2062 enum_from_to_Expr
2063         :: LHsExpr RdrName -> LHsExpr RdrName
2064         -> LHsExpr RdrName
2065 enum_from_then_to_Expr
2066         :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2067         -> LHsExpr RdrName
2068
2069 enum_from_to_Expr      f   t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
2070 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
2071
2072 showParen_Expr
2073         :: LHsExpr RdrName -> LHsExpr RdrName
2074         -> LHsExpr RdrName
2075
2076 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
2077
2078 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
2079
2080 nested_compose_Expr []  = panic "nested_compose_expr"   -- Arg is always non-empty
2081 nested_compose_Expr [e] = parenify e
2082 nested_compose_Expr (e:es)
2083   = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
2084
2085 -- impossible_Expr is used in case RHSs that should never happen.
2086 -- We generate these to keep the desugarer from complaining that they *might* happen!
2087 error_Expr :: String -> LHsExpr RdrName
2088 error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
2089
2090 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
2091 -- method. It is currently only used by Enum.{succ,pred}
2092 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
2093 illegal_Expr meth tp msg =
2094    nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
2095
2096 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
2097 -- to include the value of a_RDR in the error string.
2098 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
2099 illegal_toEnum_tag tp maxtag =
2100    nlHsApp (nlHsVar error_RDR)
2101            (nlHsApp (nlHsApp (nlHsVar append_RDR)
2102                        (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
2103                     (nlHsApp (nlHsApp (nlHsApp
2104                            (nlHsVar showsPrec_RDR)
2105                            (nlHsIntLit 0))
2106                            (nlHsVar a_RDR))
2107                            (nlHsApp (nlHsApp
2108                                (nlHsVar append_RDR)
2109                                (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
2110                                (nlHsApp (nlHsApp (nlHsApp
2111                                         (nlHsVar showsPrec_RDR)
2112                                         (nlHsIntLit 0))
2113                                         (nlHsVar maxtag))
2114                                         (nlHsLit (mkHsString ")"))))))
2115
2116 parenify :: LHsExpr RdrName -> LHsExpr RdrName
2117 parenify e@(L _ (HsVar _)) = e
2118 parenify e                 = mkHsPar e
2119
2120 -- genOpApp wraps brackets round the operator application, so that the
2121 -- renamer won't subsequently try to re-associate it.
2122 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2123 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
2124 \end{code}
2125
2126 \begin{code}
2127 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
2128     :: RdrName
2129 a_RDR           = mkVarUnqual (fsLit "a")
2130 b_RDR           = mkVarUnqual (fsLit "b")
2131 c_RDR           = mkVarUnqual (fsLit "c")
2132 d_RDR           = mkVarUnqual (fsLit "d")
2133 f_RDR           = mkVarUnqual (fsLit "f")
2134 k_RDR           = mkVarUnqual (fsLit "k")
2135 z_RDR           = mkVarUnqual (fsLit "z")
2136 ah_RDR          = mkVarUnqual (fsLit "a#")
2137 bh_RDR          = mkVarUnqual (fsLit "b#")
2138 ch_RDR          = mkVarUnqual (fsLit "c#")
2139 dh_RDR          = mkVarUnqual (fsLit "d#")
2140
2141 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
2142 as_RDRs         = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
2143 bs_RDRs         = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
2144 cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
2145
2146 a_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
2147     false_Expr, true_Expr, fmap_Expr, pure_Expr, mempty_Expr, foldMap_Expr, traverse_Expr :: LHsExpr RdrName
2148 a_Expr          = nlHsVar a_RDR
2149 -- b_Expr       = nlHsVar b_RDR
2150 c_Expr          = nlHsVar c_RDR
2151 f_Expr          = nlHsVar f_RDR
2152 z_Expr          = nlHsVar z_RDR
2153 ltTag_Expr      = nlHsVar ltTag_RDR
2154 eqTag_Expr      = nlHsVar eqTag_RDR
2155 gtTag_Expr      = nlHsVar gtTag_RDR
2156 false_Expr      = nlHsVar false_RDR
2157 true_Expr       = nlHsVar true_RDR
2158 fmap_Expr       = nlHsVar fmap_RDR
2159 pure_Expr       = nlHsVar pure_RDR
2160 mempty_Expr     = nlHsVar mempty_RDR
2161 foldMap_Expr    = nlHsVar foldMap_RDR
2162 traverse_Expr   = nlHsVar traverse_RDR
2163
2164 a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName
2165 a_Pat           = nlVarPat a_RDR
2166 b_Pat           = nlVarPat b_RDR
2167 c_Pat           = nlVarPat c_RDR
2168 d_Pat           = nlVarPat d_RDR
2169 f_Pat           = nlVarPat f_RDR
2170 k_Pat           = nlVarPat k_RDR
2171 z_Pat           = nlVarPat z_RDR
2172
2173 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
2174 -- Generates Orig s RdrName, for the binding positions
2175 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
2176 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
2177 maxtag_RDR  tycon = mk_tc_deriv_name tycon mkMaxTagOcc
2178
2179 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
2180 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
2181
2182 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
2183 mkAuxBinderName parent occ_fun = mkRdrUnqual (occ_fun (nameOccName parent))
2184 -- Was: mkDerivedRdrName name occ_fun, which made an original name
2185 -- But:  (a) that does not work well for standalone-deriving
2186 --       (b) an unqualified name is just fine, provided it can't clash with user code
2187 \end{code}
2188
2189 s RdrName for PrimOps.  Can't be done in PrelNames, because PrimOp imports
2190 PrelNames, so PrelNames can't import PrimOp.
2191
2192 \begin{code}
2193 primOpRdrName :: PrimOp -> RdrName
2194 primOpRdrName op = getRdrName (primOpId op)
2195
2196 minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, gtInt_RDR, leInt_RDR,
2197     tagToEnum_RDR :: RdrName
2198 minusInt_RDR  = primOpRdrName IntSubOp
2199 eqInt_RDR     = primOpRdrName IntEqOp
2200 ltInt_RDR     = primOpRdrName IntLtOp
2201 geInt_RDR     = primOpRdrName IntGeOp
2202 gtInt_RDR     = primOpRdrName IntGtOp
2203 leInt_RDR     = primOpRdrName IntLeOp
2204 tagToEnum_RDR = primOpRdrName TagToEnumOp
2205
2206 error_RDR :: RdrName
2207 error_RDR = getRdrName eRROR_ID
2208 \end{code}