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