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