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