Implement Partial Type Signatures
[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 PrelInfo
41 import FamInstEnv( FamInst )
42 import MkCore ( eRROR_ID )
43 import PrelNames hiding (error_RDR)
44 import MkId ( coerceId )
45 import PrimOp
46 import SrcLoc
47 import TyCon
48 import TcType
49 import TysPrim
50 import TysWiredIn
51 import Type
52 import Class
53 import TypeRep
54 import VarSet
55 import VarEnv
56 import Module
57 import State
58 import Util
59 import Var
60 import MonadUtils
61 import Outputable
62 import Lexeme
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 -> (Name -> Fixity) -> 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" (-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 :: (Name -> Fixity) -> 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 :: (Name -> Fixity) -> 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
1141                                         (nlHsLit (HsInt "" con_prec_plus_one))))
1142                          (nlHsPar (nested_compose_Expr show_thingies)))
1143         where
1144              data_con_RDR  = getRdrName data_con
1145              con_arity     = dataConSourceArity data_con
1146              bs_needed     = take con_arity bs_RDRs
1147              arg_tys       = dataConOrigArgTys data_con         -- Correspond 1-1 with bs_needed
1148              con_pat       = nlConVarPat data_con_RDR bs_needed
1149              nullary_con   = con_arity == 0
1150              labels        = dataConFieldLabels data_con
1151              lab_fields    = length labels
1152              record_syntax = lab_fields > 0
1153
1154              dc_nm          = getName data_con
1155              dc_occ_nm      = getOccName data_con
1156              con_str        = occNameString dc_occ_nm
1157              op_con_str     = wrapOpParens con_str
1158              backquote_str  = wrapOpBackquotes con_str
1159
1160              show_thingies
1161                 | is_infix      = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
1162                 | record_syntax = mk_showString_app (op_con_str ++ " {") :
1163                                   show_record_args ++ [mk_showString_app "}"]
1164                 | otherwise     = mk_showString_app (op_con_str ++ " ") : show_prefix_args
1165
1166              show_label l = mk_showString_app (nm ++ " = ")
1167                         -- Note the spaces around the "=" sign.  If we
1168                         -- don't have them then we get Foo { x=-1 } and
1169                         -- the "=-" parses as a single lexeme.  Only the
1170                         -- space after the '=' is necessary, but it
1171                         -- seems tidier to have them both sides.
1172                  where
1173                    occ_nm   = getOccName l
1174                    nm       = wrapOpParens (occNameString occ_nm)
1175
1176              show_args               = zipWith show_arg bs_needed arg_tys
1177              (show_arg1:show_arg2:_) = show_args
1178              show_prefix_args        = intersperse (nlHsVar showSpace_RDR) show_args
1179
1180                 -- Assumption for record syntax: no of fields == no of
1181                 -- labelled fields (and in same order)
1182              show_record_args = concat $
1183                                 intersperse [mk_showString_app ", "] $
1184                                 [ [show_label lbl, arg]
1185                                 | (lbl,arg) <- zipEqual "gen_Show_binds"
1186                                                         labels show_args ]
1187
1188                 -- Generates (showsPrec p x) for argument x, but it also boxes
1189                 -- the argument first if necessary.  Note that this prints unboxed
1190                 -- things without any '#' decorations; could change that if need be
1191              show_arg b arg_ty = nlHsApps showsPrec_RDR
1192                                     [nlHsLit (HsInt "" arg_prec),
1193                                     box_if_necy "Show" tycon (nlHsVar b) arg_ty]
1194
1195                 -- Fixity stuff
1196              is_infix = dataConIsInfix data_con
1197              con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1198              arg_prec | record_syntax = 0  -- Record fields don't need parens
1199                       | otherwise     = con_prec_plus_one
1200
1201 wrapOpParens :: String -> String
1202 wrapOpParens s | isSym s   = '(' : s ++ ")"
1203                | otherwise = s
1204
1205 wrapOpBackquotes :: String -> String
1206 wrapOpBackquotes s | isSym s   = s
1207                    | otherwise = '`' : s ++ "`"
1208
1209 isSym :: String -> Bool
1210 isSym ""      = False
1211 isSym (c : _) = startsVarSym c || startsConSym c
1212
1213 mk_showString_app :: String -> LHsExpr RdrName
1214 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1215 \end{code}
1216
1217 \begin{code}
1218 getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer
1219 getPrec is_infix get_fixity nm
1220   | not is_infix   = appPrecedence
1221   | otherwise      = getPrecedence get_fixity nm
1222
1223 appPrecedence :: Integer
1224 appPrecedence = fromIntegral maxPrecedence + 1
1225   -- One more than the precedence of the most
1226   -- tightly-binding operator
1227
1228 getPrecedence :: (Name -> Fixity) -> Name -> Integer
1229 getPrecedence get_fixity nm
1230    = case get_fixity nm of
1231         Fixity x _assoc -> fromIntegral x
1232           -- NB: the Report says that associativity is not taken
1233           --     into account for either Read or Show; hence we
1234           --     ignore associativity here
1235 \end{code}
1236
1237
1238 %************************************************************************
1239 %*                                                                      *
1240 \subsection{Typeable (new)}
1241 %*                                                                      *
1242 %************************************************************************
1243
1244 From the data type
1245
1246         data T a b = ....
1247
1248 we generate
1249
1250         instance Typeable2 T where
1251                 typeOf2 _ = mkTyConApp (mkTyCon <hash-high> <hash-low>
1252                                                 <pkg> <module> "T") []
1253
1254 We are passed the Typeable2 class as well as T
1255
1256 \begin{code}
1257 gen_Typeable_binds :: DynFlags -> SrcSpan -> TyCon
1258                    -> (LHsBinds RdrName, BagDerivStuff)
1259 gen_Typeable_binds dflags loc tycon
1260   = ( unitBag $ mk_easy_FunBind loc typeRep_RDR [nlWildPat]
1261                 (nlHsApps mkTyConApp_RDR [tycon_rep, nlList []])
1262     , emptyBag )
1263   where
1264     tycon_name = tyConName tycon
1265     modl       = nameModule tycon_name
1266     pkg        = modulePackageKey modl
1267
1268     modl_fs    = moduleNameFS (moduleName modl)
1269     pkg_fs     = packageKeyFS pkg
1270     name_fs    = occNameFS (nameOccName tycon_name)
1271
1272     tycon_rep = nlHsApps mkTyCon_RDR
1273                     (map nlHsLit [int64 high,
1274                                   int64 low,
1275                                   HsString "" pkg_fs,
1276                                   HsString "" modl_fs,
1277                                   HsString "" name_fs])
1278
1279     hashThis = unwords $ map unpackFS [pkg_fs, modl_fs, name_fs]
1280     Fingerprint high low = fingerprintString hashThis
1281
1282     int64
1283       | wORD_SIZE dflags == 4 = HsWord64Prim "" . fromIntegral
1284       | otherwise             = HsWordPrim "" . fromIntegral
1285 \end{code}
1286
1287
1288
1289 %************************************************************************
1290 %*                                                                      *
1291         Data instances
1292 %*                                                                      *
1293 %************************************************************************
1294
1295 From the data type
1296
1297   data T a b = T1 a b | T2
1298
1299 we generate
1300
1301   $cT1 = mkDataCon $dT "T1" Prefix
1302   $cT2 = mkDataCon $dT "T2" Prefix
1303   $dT  = mkDataType "Module.T" [] [$con_T1, $con_T2]
1304   -- the [] is for field labels.
1305
1306   instance (Data a, Data b) => Data (T a b) where
1307     gfoldl k z (T1 a b) = z T `k` a `k` b
1308     gfoldl k z T2           = z T2
1309     -- ToDo: add gmapT,Q,M, gfoldr
1310
1311     gunfold k z c = case conIndex c of
1312                         I# 1# -> k (k (z T1))
1313                         I# 2# -> z T2
1314
1315     toConstr (T1 _ _) = $cT1
1316     toConstr T2       = $cT2
1317
1318     dataTypeOf _ = $dT
1319
1320     dataCast1 = gcast1   -- If T :: * -> *
1321     dataCast2 = gcast2   -- if T :: * -> * -> *
1322
1323
1324 \begin{code}
1325 gen_Data_binds :: DynFlags
1326                 -> SrcSpan
1327                -> TyCon
1328                -> (LHsBinds RdrName,    -- The method bindings
1329                    BagDerivStuff)       -- Auxiliary bindings
1330 gen_Data_binds dflags loc tycon
1331   = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
1332      `unionBags` gcast_binds,
1333                 -- Auxiliary definitions: the data type and constructors
1334      listToBag ( DerivHsBind (genDataTyCon)
1335                : map (DerivHsBind . genDataDataCon) data_cons))
1336   where
1337     data_cons  = tyConDataCons tycon
1338     n_cons     = length data_cons
1339     one_constr = n_cons == 1
1340
1341     genDataTyCon :: (LHsBind RdrName, LSig RdrName)
1342     genDataTyCon        --  $dT
1343       = (mkHsVarBind loc rdr_name rhs,
1344          L loc (TypeSig [L loc rdr_name] sig_ty PlaceHolder))
1345       where
1346         rdr_name = mk_data_type_name tycon
1347         sig_ty   = nlHsTyVar dataType_RDR
1348         constrs  = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
1349         rhs = nlHsVar mkDataType_RDR
1350               `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr tycon)))
1351               `nlHsApp` nlList constrs
1352
1353     genDataDataCon :: DataCon -> (LHsBind RdrName, LSig RdrName)
1354     genDataDataCon dc       --  $cT1 etc
1355       = (mkHsVarBind loc rdr_name rhs,
1356          L loc (TypeSig [L loc rdr_name] sig_ty PlaceHolder))
1357       where
1358         rdr_name = mk_constr_name dc
1359         sig_ty   = nlHsTyVar constr_RDR
1360         rhs      = nlHsApps mkConstr_RDR constr_args
1361
1362         constr_args
1363            = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1364            nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
1365            nlHsLit (mkHsString (occNameString dc_occ)),   -- String name
1366                nlList  labels,                            -- Field labels
1367            nlHsVar fixity]                                -- Fixity
1368
1369         labels   = map (nlHsLit . mkHsString . getOccString)
1370                        (dataConFieldLabels dc)
1371         dc_occ   = getOccName dc
1372         is_infix = isDataSymOcc dc_occ
1373         fixity | is_infix  = infix_RDR
1374            | otherwise = prefix_RDR
1375
1376         ------------ gfoldl
1377     gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons)
1378
1379     gfoldl_eqn con
1380       = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1381                        foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1382                    where
1383                      con_name ::  RdrName
1384                      con_name = getRdrName con
1385                      as_needed = take (dataConSourceArity con) as_RDRs
1386                      mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1387
1388         ------------ gunfold
1389     gunfold_bind = mk_FunBind loc
1390                               gunfold_RDR
1391                               [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1392                                 gunfold_rhs)]
1393
1394     gunfold_rhs
1395         | one_constr = mk_unfold_rhs (head data_cons)   -- No need for case
1396         | otherwise  = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1397                                 (map gunfold_alt data_cons)
1398
1399     gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1400     mk_unfold_rhs dc = foldr nlHsApp
1401                            (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1402                            (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1403
1404     mk_unfold_pat dc    -- Last one is a wild-pat, to avoid
1405                         -- redundant test, and annoying warning
1406       | tag-fIRST_TAG == n_cons-1 = nlWildPat   -- Last constructor
1407       | otherwise = nlConPat intDataCon_RDR
1408                              [nlLitPat (HsIntPrim "" (toInteger tag))]
1409       where
1410         tag = dataConTag dc
1411
1412         ------------ toConstr
1413     toCon_bind = mk_FunBind loc toConstr_RDR (map to_con_eqn data_cons)
1414     to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1415
1416         ------------ dataTypeOf
1417     dataTypeOf_bind = mk_easy_FunBind
1418                         loc
1419                         dataTypeOf_RDR
1420                         [nlWildPat]
1421                         (nlHsVar (mk_data_type_name tycon))
1422
1423         ------------ gcast1/2
1424     tycon_kind = tyConKind tycon
1425     gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR
1426                 | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
1427                 | otherwise                 = emptyBag
1428     mk_gcast dataCast_RDR gcast_RDR
1429       = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
1430                                  (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
1431
1432
1433 kind1, kind2 :: Kind
1434 kind1 = liftedTypeKind `mkArrowKind` liftedTypeKind
1435 kind2 = liftedTypeKind `mkArrowKind` kind1
1436
1437 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
1438     mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
1439     dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,
1440     constr_RDR, dataType_RDR,
1441     eqChar_RDR  , ltChar_RDR  , geChar_RDR  , gtChar_RDR  , leChar_RDR  ,
1442     eqInt_RDR   , ltInt_RDR   , geInt_RDR   , gtInt_RDR   , leInt_RDR   ,
1443     eqWord_RDR  , ltWord_RDR  , geWord_RDR  , gtWord_RDR  , leWord_RDR  ,
1444     eqAddr_RDR  , ltAddr_RDR  , geAddr_RDR  , gtAddr_RDR  , leAddr_RDR  ,
1445     eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,
1446     eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR :: RdrName
1447 gfoldl_RDR     = varQual_RDR  gENERICS (fsLit "gfoldl")
1448 gunfold_RDR    = varQual_RDR  gENERICS (fsLit "gunfold")
1449 toConstr_RDR   = varQual_RDR  gENERICS (fsLit "toConstr")
1450 dataTypeOf_RDR = varQual_RDR  gENERICS (fsLit "dataTypeOf")
1451 dataCast1_RDR  = varQual_RDR  gENERICS (fsLit "dataCast1")
1452 dataCast2_RDR  = varQual_RDR  gENERICS (fsLit "dataCast2")
1453 gcast1_RDR     = varQual_RDR  tYPEABLE (fsLit "gcast1")
1454 gcast2_RDR     = varQual_RDR  tYPEABLE (fsLit "gcast2")
1455 mkConstr_RDR   = varQual_RDR  gENERICS (fsLit "mkConstr")
1456 constr_RDR     = tcQual_RDR   gENERICS (fsLit "Constr")
1457 mkDataType_RDR = varQual_RDR  gENERICS (fsLit "mkDataType")
1458 dataType_RDR   = tcQual_RDR   gENERICS (fsLit "DataType")
1459 conIndex_RDR   = varQual_RDR  gENERICS (fsLit "constrIndex")
1460 prefix_RDR     = dataQual_RDR gENERICS (fsLit "Prefix")
1461 infix_RDR      = dataQual_RDR gENERICS (fsLit "Infix")
1462
1463 eqChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqChar#")
1464 ltChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltChar#")
1465 leChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "leChar#")
1466 gtChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtChar#")
1467 geChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "geChar#")
1468
1469 eqInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "==#")
1470 ltInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "<#" )
1471 leInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "<=#")
1472 gtInt_RDR      = varQual_RDR  gHC_PRIM (fsLit ">#" )
1473 geInt_RDR      = varQual_RDR  gHC_PRIM (fsLit ">=#")
1474
1475 eqWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqWord#")
1476 ltWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltWord#")
1477 leWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "leWord#")
1478 gtWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtWord#")
1479 geWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "geWord#")
1480
1481 eqAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqAddr#")
1482 ltAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltAddr#")
1483 leAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "leAddr#")
1484 gtAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtAddr#")
1485 geAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "geAddr#")
1486
1487 eqFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "eqFloat#")
1488 ltFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "ltFloat#")
1489 leFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "leFloat#")
1490 gtFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "gtFloat#")
1491 geFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "geFloat#")
1492
1493 eqDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit "==##")
1494 ltDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit "<##" )
1495 leDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit "<=##")
1496 gtDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit ">##" )
1497 geDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit ">=##")
1498 \end{code}
1499
1500
1501
1502 %************************************************************************
1503 %*                                                                      *
1504                         Functor instances
1505
1506  see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1507
1508 %*                                                                      *
1509 %************************************************************************
1510
1511 For the data type:
1512
1513   data T a = T1 Int a | T2 (T a)
1514
1515 We generate the instance:
1516
1517   instance Functor T where
1518       fmap f (T1 b1 a) = T1 b1 (f a)
1519       fmap f (T2 ta)   = T2 (fmap f ta)
1520
1521 Notice that we don't simply apply 'fmap' to the constructor arguments.
1522 Rather
1523   - Do nothing to an argument whose type doesn't mention 'a'
1524   - Apply 'f' to an argument of type 'a'
1525   - Apply 'fmap f' to other arguments
1526 That's why we have to recurse deeply into the constructor argument types,
1527 rather than just one level, as we typically do.
1528
1529 What about types with more than one type parameter?  In general, we only
1530 derive Functor for the last position:
1531
1532   data S a b = S1 [b] | S2 (a, T a b)
1533   instance Functor (S a) where
1534     fmap f (S1 bs)    = S1 (fmap f bs)
1535     fmap f (S2 (p,q)) = S2 (a, fmap f q)
1536
1537 However, we have special cases for
1538          - tuples
1539          - functions
1540
1541 More formally, we write the derivation of fmap code over type variable
1542 'a for type 'b as ($fmap 'a 'b).  In this general notation the derived
1543 instance for T is:
1544
1545   instance Functor T where
1546       fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
1547       fmap f (T2 x1)    = T2 ($(fmap 'a '(T a)) x1)
1548
1549   $(fmap 'a 'b)          =  \x -> x     -- when b does not contain a
1550   $(fmap 'a 'a)          =  f
1551   $(fmap 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
1552   $(fmap 'a '(T b1 b2))  =  fmap $(fmap 'a 'b2)   -- when a only occurs in the last parameter, b2
1553   $(fmap 'a '(b -> c))   =  \x b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
1554
1555 For functions, the type parameter 'a can occur in a contravariant position,
1556 which means we need to derive a function like:
1557
1558   cofmap :: (a -> b) -> (f b -> f a)
1559
1560 This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
1561
1562   $(cofmap 'a 'b)          =  \x -> x     -- when b does not contain a
1563   $(cofmap 'a 'a)          =  error "type variable in contravariant position"
1564   $(cofmap 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
1565   $(cofmap 'a '[b])        =  map $(cofmap 'a 'b)
1566   $(cofmap 'a '(T b1 b2))  =  fmap $(cofmap 'a 'b2)   -- when a only occurs in the last parameter, b2
1567   $(cofmap 'a '(b -> c))   =  \x b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
1568
1569 Note that the code produced by $(fmap _ _) is always a higher order function,
1570 with type `(a -> b) -> (g a -> g b)` for some g. When we need to do pattern
1571 matching on the type, this means create a lambda function (see the (,) case above).
1572 The resulting code for fmap can look a bit weird, for example:
1573
1574   data X a = X (a,Int)
1575   -- generated instance
1576   instance Functor X where
1577       fmap f (X x) = (\y -> case y of (x1,x2) -> X (f x1, (\z -> z) x2)) x
1578
1579 The optimizer should be able to simplify this code by simple inlining.
1580
1581 An older version of the deriving code tried to avoid these applied
1582 lambda functions by producing a meta level function. But the function to
1583 be mapped, `f`, is a function on the code level, not on the meta level,
1584 so it was eta expanded to `\x -> [| f $x |]`. This resulted in too much eta expansion.
1585 It is better to produce too many lambdas than to eta expand, see ticket #7436.
1586
1587 \begin{code}
1588 gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1589 gen_Functor_binds loc tycon
1590   = (unitBag fmap_bind, emptyBag)
1591   where
1592     data_cons = tyConDataCons tycon
1593     fmap_bind = mkRdrFunBind (L loc fmap_RDR) eqns
1594
1595     fmap_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
1596       where
1597         parts = sequence $ foldDataConArgs ft_fmap con
1598
1599     eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat]
1600                                            (error_Expr "Void fmap")]
1601          | otherwise      = map fmap_eqn data_cons
1602
1603     ft_fmap :: FFoldType (State [RdrName] (LHsExpr RdrName))
1604     ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x    -- fmap f = \x -> x
1605                  , ft_var  = return f_Expr                   -- fmap f = f
1606                  , ft_fun  = \g h -> do                      -- fmap f = \x b -> h (x (g b))
1607                                  gg <- g
1608                                  hh <- h
1609                                  mkSimpleLam2 $ \x b -> return $ nlHsApp hh (nlHsApp x (nlHsApp gg b))
1610                  , ft_tup = \t gs -> do                      -- fmap f = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
1611                                  gg <- sequence gs
1612                                  mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
1613                  , ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g  -- fmap f = fmap g
1614                  , ft_forall = \_ g -> g
1615                  , ft_bad_app = panic "in other argument"
1616                  , ft_co_var = panic "contravariant" }
1617
1618     -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
1619     match_for_con :: [LPat RdrName] -> DataCon -> [LHsExpr RdrName]
1620                   -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
1621     match_for_con = mkSimpleConMatch $
1622         \con_name xs -> return $ nlHsApps con_name xs  -- Con x1 x2 ..
1623 \end{code}
1624
1625 Utility functions related to Functor deriving.
1626
1627 Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
1628 This function works like a fold: it makes a value of type 'a' in a bottom up way.
1629
1630 \begin{code}
1631 -- Generic traversal for Functor deriving
1632 data FFoldType a      -- Describes how to fold over a Type in a functor like way
1633    = FT { ft_triv    :: a                   -- Does not contain variable
1634         , ft_var     :: a                   -- The variable itself
1635         , ft_co_var  :: a                   -- The variable itself, contravariantly
1636         , ft_fun     :: a -> a -> a         -- Function type
1637         , ft_tup     :: TupleSort -> [a] -> a  -- Tuple type
1638         , ft_ty_app  :: Type -> a -> a      -- Type app, variable only in last argument
1639         , ft_bad_app :: a                   -- Type app, variable other than in last argument
1640         , ft_forall  :: TcTyVar -> a -> a   -- Forall type
1641      }
1642
1643 functorLikeTraverse :: forall a.
1644                        TyVar         -- ^ Variable to look for
1645                     -> FFoldType a   -- ^ How to fold
1646                     -> Type          -- ^ Type to process
1647                     -> a
1648 functorLikeTraverse var (FT { ft_triv = caseTrivial,     ft_var = caseVar
1649                             , ft_co_var = caseCoVar,     ft_fun = caseFun
1650                             , ft_tup = caseTuple,        ft_ty_app = caseTyApp
1651                             , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
1652                     ty
1653   = fst (go False ty)
1654   where
1655     go :: Bool        -- Covariant or contravariant context
1656        -> Type
1657        -> (a, Bool)   -- (result of type a, does type contain var)
1658
1659     go co ty | Just ty' <- coreView ty = go co ty'
1660     go co (TyVarTy    v) | v == var = (if co then caseCoVar else caseVar,True)
1661     go co (FunTy x y)  | isPredTy x = go co y
1662                        | xc || yc   = (caseFun xr yr,True)
1663         where (xr,xc) = go (not co) x
1664               (yr,yc) = go co       y
1665     go co (AppTy    x y) | xc = (caseWrongArg,   True)
1666                          | yc = (caseTyApp x yr, True)
1667         where (_, xc) = go co x
1668               (yr,yc) = go co y
1669     go co ty@(TyConApp con args)
1670        | not (or xcs)     = (caseTrivial, False)   -- Variable does not occur
1671        -- At this point we know that xrs, xcs is not empty,
1672        -- and at least one xr is True
1673        | isTupleTyCon con = (caseTuple (tupleTyConSort con) xrs, True)
1674        | or (init xcs)    = (caseWrongArg, True)         -- T (..var..)    ty
1675        | otherwise        = case splitAppTy_maybe ty of  -- T (..no var..) ty
1676                               Nothing -> (caseWrongArg, True)   -- Non-decomposable (eg type function)
1677                               Just (fun_ty, _) -> (caseTyApp fun_ty (last xrs), True)
1678        where
1679          (xrs,xcs) = unzip (map (go co) args)
1680     go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True)
1681         where (xr,xc) = go co x
1682     go _ _ = (caseTrivial,False)
1683
1684 -- Return all syntactic subterms of ty that contain var somewhere
1685 -- These are the things that should appear in instance constraints
1686 deepSubtypesContaining :: TyVar -> Type -> [TcType]
1687 deepSubtypesContaining tv
1688   = functorLikeTraverse tv
1689         (FT { ft_triv = []
1690             , ft_var = []
1691             , ft_fun = (++)
1692             , ft_tup = \_ xs -> concat xs
1693             , ft_ty_app = (:)
1694             , ft_bad_app = panic "in other argument"
1695             , ft_co_var = panic "contravariant"
1696             , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyVarsOfType) xs })
1697
1698
1699 foldDataConArgs :: FFoldType a -> DataCon -> [a]
1700 -- Fold over the arguments of the datacon
1701 foldDataConArgs ft con
1702   = map (functorLikeTraverse tv ft) (dataConOrigArgTys con)
1703   where
1704     Just tv = getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con)))
1705         -- Argument to derive for, 'a in the above description
1706         -- The validity and kind checks have ensured that
1707         -- the Just will match and a::*
1708
1709 -- Make a HsLam using a fresh variable from a State monad
1710 mkSimpleLam :: (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1711             -> State [RdrName] (LHsExpr RdrName)
1712 -- (mkSimpleLam fn) returns (\x. fn(x))
1713 mkSimpleLam lam = do
1714     (n:names) <- get
1715     put names
1716     body <- lam (nlHsVar n)
1717     return (mkHsLam [nlVarPat n] body)
1718
1719 mkSimpleLam2 :: (LHsExpr RdrName -> LHsExpr RdrName
1720              -> State [RdrName] (LHsExpr RdrName))
1721              -> State [RdrName] (LHsExpr RdrName)
1722 mkSimpleLam2 lam = do
1723     (n1:n2:names) <- get
1724     put names
1725     body <- lam (nlHsVar n1) (nlHsVar n2)
1726     return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
1727
1728 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
1729 mkSimpleConMatch :: Monad m => (RdrName -> [LHsExpr RdrName] -> m (LHsExpr RdrName))
1730                  -> [LPat RdrName]
1731                  -> DataCon
1732                  -> [LHsExpr RdrName]
1733                  -> m (LMatch RdrName (LHsExpr RdrName))
1734 mkSimpleConMatch fold extra_pats con insides = do
1735     let con_name = getRdrName con
1736     let vars_needed = takeList insides as_RDRs
1737     let pat = nlConVarPat con_name vars_needed
1738     rhs <- fold con_name (zipWith nlHsApp insides (map nlHsVar vars_needed))
1739     return $ mkMatch (extra_pats ++ [pat]) rhs emptyLocalBinds
1740
1741 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
1742 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [a]
1743                                  -> m (LMatch RdrName (LHsExpr RdrName)))
1744                   -> TupleSort -> [a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
1745 mkSimpleTupleCase match_for_con sort insides x = do
1746     let con = tupleCon sort (length insides)
1747     match <- match_for_con [] con insides
1748     return $ nlHsCase x [match]
1749 \end{code}
1750
1751
1752 %************************************************************************
1753 %*                                                                      *
1754                         Foldable instances
1755
1756  see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1757
1758 %*                                                                      *
1759 %************************************************************************
1760
1761 Deriving Foldable instances works the same way as Functor instances,
1762 only Foldable instances are not possible for function types at all.
1763 Here the derived instance for the type T above is:
1764
1765   instance Foldable T where
1766       foldr f z (T1 x1 x2 x3) = $(foldr 'a 'b1) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a 'b2) x3 z ) )
1767
1768 The cases are:
1769
1770   $(foldr 'a 'b)         =  \x z -> z     -- when b does not contain a
1771   $(foldr 'a 'a)         =  f
1772   $(foldr 'a '(b1,b2))   =  \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
1773   $(foldr 'a '(T b1 b2)) =  \x z -> foldr $(foldr 'a 'b2) z x  -- when a only occurs in the last parameter, b2
1774
1775 Note that the arguments to the real foldr function are the wrong way around,
1776 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
1777
1778 \begin{code}
1779 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1780 gen_Foldable_binds loc tycon
1781   = (listToBag [foldr_bind, foldMap_bind], emptyBag)
1782   where
1783     data_cons = tyConDataCons tycon
1784
1785     foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns
1786     eqns = map foldr_eqn data_cons
1787     foldr_eqn con = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs
1788       where
1789         parts = sequence $ foldDataConArgs ft_foldr con
1790
1791     foldMap_bind = mkRdrFunBind (L loc foldMap_RDR) (map foldMap_eqn data_cons)
1792     foldMap_eqn con = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs
1793       where
1794         parts = sequence $ foldDataConArgs ft_foldMap con
1795
1796     ft_foldr :: FFoldType (State [RdrName] (LHsExpr RdrName))
1797     ft_foldr = FT { ft_triv    = mkSimpleLam2 $ \_ z -> return z       -- foldr f = \x z -> z
1798                   , ft_var     = return f_Expr                         -- foldr f = f
1799                   , ft_tup     = \t g -> do gg <- sequence g           -- foldr f = (\x z -> case x of ...)
1800                                             mkSimpleLam2 $ \x z -> mkSimpleTupleCase (match_foldr z) t gg x
1801                   , ft_ty_app  = \_ g -> do gg <- g                    -- foldr f = (\x z -> foldr g z x)
1802                                             mkSimpleLam2 $ \x z -> return $ nlHsApps foldable_foldr_RDR [gg,z,x]
1803                   , ft_forall  = \_ g -> g
1804                   , ft_co_var  = panic "contravariant"
1805                   , ft_fun     = panic "function"
1806                   , ft_bad_app = panic "in other argument" }
1807
1808     match_foldr z = mkSimpleConMatch $ \_con_name xs -> return $ foldr nlHsApp z xs -- g1 v1 (g2 v2 (.. z))
1809
1810     ft_foldMap :: FFoldType (State [RdrName] (LHsExpr RdrName))
1811     ft_foldMap = FT { ft_triv = mkSimpleLam $ \_ -> return mempty_Expr  -- foldMap f = \x -> mempty
1812                     , ft_var  = return f_Expr                           -- foldMap f = f
1813                     , ft_tup  = \t g -> do gg <- sequence g             -- foldMap f = \x -> case x of (..,)
1814                                            mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg
1815                     , ft_ty_app = \_ g -> nlHsApp foldMap_Expr <$> g    -- foldMap f = foldMap g
1816                     , ft_forall = \_ g -> g
1817                     , ft_co_var = panic "contravariant"
1818                     , ft_fun = panic "function"
1819                     , ft_bad_app = panic "in other argument" }
1820
1821     match_foldMap = mkSimpleConMatch $ \_con_name xs -> return $
1822         case xs of
1823             [] -> mempty_Expr
1824             xs -> foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs
1825
1826 \end{code}
1827
1828
1829 %************************************************************************
1830 %*                                                                      *
1831                         Traversable instances
1832
1833  see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1834 %*                                                                      *
1835 %************************************************************************
1836
1837 Again, Traversable is much like Functor and Foldable.
1838
1839 The cases are:
1840
1841   $(traverse 'a 'b)          =  pure     -- when b does not contain a
1842   $(traverse 'a 'a)          =  f
1843   $(traverse 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
1844   $(traverse 'a '(T b1 b2))  =  traverse $(traverse 'a 'b2)  -- when a only occurs in the last parameter, b2
1845
1846 Note that the generated code is not as efficient as it could be. For instance:
1847
1848   data T a = T Int a  deriving Traversable
1849
1850 gives the function: traverse f (T x y) = T <$> pure x <*> f y
1851 instead of:         traverse f (T x y) = T x <$> f y
1852
1853 \begin{code}
1854 gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1855 gen_Traversable_binds loc tycon
1856   = (unitBag traverse_bind, emptyBag)
1857   where
1858     data_cons = tyConDataCons tycon
1859
1860     traverse_bind = mkRdrFunBind (L loc traverse_RDR) eqns
1861     eqns = map traverse_eqn data_cons
1862     traverse_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
1863       where
1864         parts = sequence $ foldDataConArgs ft_trav con
1865
1866
1867     ft_trav :: FFoldType (State [RdrName] (LHsExpr RdrName))
1868     ft_trav = FT { ft_triv    = return pure_Expr                  -- traverse f = pure x
1869                  , ft_var     = return f_Expr                     -- traverse f = f x
1870                  , ft_tup     = \t gs -> do                       -- traverse f = \x -> case x of (a1,a2,..) ->
1871                                     gg <- sequence gs             --                   (,,) <$> g1 a1 <*> g2 a2 <*> ..
1872                                     mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
1873                  , ft_ty_app  = \_ g -> nlHsApp traverse_Expr <$> g  -- traverse f = travese g
1874                  , ft_forall  = \_ g -> g
1875                  , ft_co_var  = panic "contravariant"
1876                  , ft_fun     = panic "function"
1877                  , ft_bad_app = panic "in other argument" }
1878
1879     -- Con a1 a2 ... -> Con <$> g1 a1 <*> g2 a2 <*> ...
1880     match_for_con = mkSimpleConMatch $
1881         \con_name xs -> return $ mkApCon (nlHsVar con_name) xs
1882
1883     -- ((Con <$> x1) <*> x2) <*> ..
1884     mkApCon con []     = nlHsApps pure_RDR [con]
1885     mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
1886        where appAp x y = nlHsApps ap_RDR [x,y]
1887 \end{code}
1888
1889 %************************************************************************
1890 %*                                                                      *
1891                      Newtype-deriving instances
1892 %*                                                                      *
1893 %************************************************************************
1894
1895 We take every method in the original instance and `coerce` it to fit
1896 into the derived instance. We need a type annotation on the argument
1897 to `coerce` to make it obvious what instantiation of the method we're
1898 coercing from.
1899
1900 See #8503 for more discussion.
1901
1902 \begin{code}
1903 mkCoerceClassMethEqn :: Class   -- the class being derived
1904                      -> [TyVar] -- the tvs in the instance head
1905                      -> [Type]  -- instance head parameters (incl. newtype)
1906                      -> Type    -- the representation type (already eta-reduced)
1907                      -> Id      -- the method to look at
1908                      -> Pair Type
1909 mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty id
1910   = Pair (substTy rhs_subst user_meth_ty) (substTy lhs_subst user_meth_ty)
1911   where
1912     cls_tvs = classTyVars cls
1913     in_scope = mkInScopeSet $ mkVarSet inst_tvs
1914     lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs cls_tys)
1915     rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast cls_tys rhs_ty))
1916     (_class_tvs, _class_constraint, user_meth_ty) = tcSplitSigmaTy (varType id)
1917
1918     changeLast :: [a] -> a -> [a]
1919     changeLast []     _  = panic "changeLast"
1920     changeLast [_]    x  = [x]
1921     changeLast (x:xs) x' = x : changeLast xs x'
1922
1923
1924 gen_Newtype_binds :: SrcSpan
1925                   -> Class   -- the class being derived
1926                   -> [TyVar] -- the tvs in the instance head
1927                   -> [Type]  -- instance head parameters (incl. newtype)
1928                   -> Type    -- the representation type (already eta-reduced)
1929                   -> LHsBinds RdrName
1930 gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty
1931   = listToBag $ zipWith mk_bind
1932         (classMethods cls)
1933         (map (mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty) (classMethods cls))
1934   where
1935     coerce_RDR = getRdrName coerceId
1936     mk_bind :: Id -> Pair Type -> LHsBind RdrName
1937     mk_bind id (Pair tau_ty user_ty)
1938       = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch [] rhs_expr]
1939       where
1940         meth_RDR = getRdrName id
1941         rhs_expr
1942           = ( nlHsVar coerce_RDR
1943                 `nlHsApp`
1944               (nlHsVar meth_RDR `nlExprWithTySig` toHsType tau_ty'))
1945             `nlExprWithTySig` toHsType user_ty
1946         -- Open the representation type here, so that it's forall'ed type
1947         -- variables refer to the ones bound in the user_ty
1948         (_, _, tau_ty')  = tcSplitSigmaTy tau_ty
1949
1950     nlExprWithTySig :: LHsExpr RdrName -> LHsType RdrName -> LHsExpr RdrName
1951     nlExprWithTySig e s = noLoc (ExprWithTySig e s PlaceHolder)
1952 \end{code}
1953
1954 %************************************************************************
1955 %*                                                                      *
1956 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1957 %*                                                                      *
1958 %************************************************************************
1959
1960 \begin{verbatim}
1961 data Foo ... = ...
1962
1963 con2tag_Foo :: Foo ... -> Int#
1964 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
1965 maxtag_Foo  :: Int              -- ditto (NB: not unlifted)
1966 \end{verbatim}
1967
1968 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1969 fiddling around.
1970
1971 \begin{code}
1972 genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName)
1973 genAuxBindSpec loc (DerivCon2Tag tycon)
1974   = (mk_FunBind loc rdr_name eqns,
1975      L loc (TypeSig [L loc rdr_name] (L loc sig_ty) PlaceHolder))
1976   where
1977     rdr_name = con2tag_RDR tycon
1978
1979     sig_ty = HsCoreTy $
1980              mkSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
1981              mkParentType tycon `mkFunTy` intPrimTy
1982
1983     lots_of_constructors = tyConFamilySize tycon > 8
1984                         -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1985                         -- but we don't do vectored returns any more.
1986
1987     eqns | lots_of_constructors = [get_tag_eqn]
1988          | otherwise = map mk_eqn (tyConDataCons tycon)
1989
1990     get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
1991
1992     mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1993     mk_eqn con = ([nlWildConPat con],
1994                   nlHsLit (HsIntPrim ""
1995                                     (toInteger ((dataConTag con) - fIRST_TAG))))
1996
1997 genAuxBindSpec loc (DerivTag2Con tycon)
1998   = (mk_FunBind loc rdr_name
1999         [([nlConVarPat intDataCon_RDR [a_RDR]],
2000            nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
2001      L loc (TypeSig [L loc rdr_name] (L loc sig_ty) PlaceHolder))
2002   where
2003     sig_ty = HsCoreTy $ mkForAllTys (tyConTyVars tycon) $
2004              intTy `mkFunTy` mkParentType tycon
2005
2006     rdr_name = tag2con_RDR tycon
2007
2008 genAuxBindSpec loc (DerivMaxTag tycon)
2009   = (mkHsVarBind loc rdr_name rhs,
2010      L loc (TypeSig [L loc rdr_name] (L loc sig_ty) PlaceHolder))
2011   where
2012     rdr_name = maxtag_RDR tycon
2013     sig_ty = HsCoreTy intTy
2014     rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim "" max_tag))
2015     max_tag =  case (tyConDataCons tycon) of
2016                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
2017
2018 type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings
2019                               ( Bag (LHsBind RdrName, LSig RdrName)
2020                                 -- Extra bindings (used by Generic only)
2021                               , Bag TyCon   -- Extra top-level datatypes
2022                               , Bag (FamInst)           -- Extra family instances
2023                               , Bag (InstInfo RdrName)) -- Extra instances
2024
2025 genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
2026 genAuxBinds loc b = genAuxBinds' b2 where
2027   (b1,b2) = partitionBagWith splitDerivAuxBind b
2028   splitDerivAuxBind (DerivAuxBind x) = Left x
2029   splitDerivAuxBind  x               = Right x
2030
2031   rm_dups = foldrBag dup_check emptyBag
2032   dup_check a b = if anyBag (== a) b then b else consBag a b
2033
2034   genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
2035   genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec loc) (rm_dups b1)
2036                             , emptyBag, emptyBag, emptyBag)
2037   f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
2038   f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
2039   f (DerivHsBind  b) = add1 b
2040   f (DerivTyCon   t) = add2 t
2041   f (DerivFamInst t) = add3 t
2042   f (DerivInst    i) = add4 i
2043
2044   add1 x (a,b,c,d) = (x `consBag` a,b,c,d)
2045   add2 x (a,b,c,d) = (a,x `consBag` b,c,d)
2046   add3 x (a,b,c,d) = (a,b,x `consBag` c,d)
2047   add4 x (a,b,c,d) = (a,b,c,x `consBag` d)
2048
2049 mk_data_type_name :: TyCon -> RdrName   -- "$tT"
2050 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
2051
2052 mk_constr_name :: DataCon -> RdrName    -- "$cC"
2053 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
2054
2055 mkParentType :: TyCon -> Type
2056 -- Turn the representation tycon of a family into
2057 -- a use of its family constructor
2058 mkParentType tc
2059   = case tyConFamInst_maybe tc of
2060        Nothing  -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
2061        Just (fam_tc,tys) -> mkTyConApp fam_tc tys
2062 \end{code}
2063
2064 %************************************************************************
2065 %*                                                                      *
2066 \subsection{Utility bits for generating bindings}
2067 %*                                                                      *
2068 %************************************************************************
2069
2070
2071 \begin{code}
2072 mk_FunBind :: SrcSpan -> RdrName
2073            -> [([LPat RdrName], LHsExpr RdrName)]
2074            -> LHsBind RdrName
2075 mk_FunBind loc fun pats_and_exprs
2076   = mkRdrFunBind (L loc fun) matches
2077   where
2078     matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
2079
2080 mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
2081 mkRdrFunBind fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
2082  where
2083    -- Catch-all eqn looks like
2084    --     fmap = error "Void fmap"
2085    -- It's needed if there no data cons at all,
2086    -- which can happen with -XEmptyDataDecls
2087    -- See Trac #4302
2088    matches' = if null matches
2089               then [mkMatch [] (error_Expr str) emptyLocalBinds]
2090               else matches
2091    str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
2092 \end{code}
2093
2094 \begin{code}
2095 box_if_necy :: String           -- The class involved
2096             -> TyCon            -- The tycon involved
2097             -> LHsExpr RdrName  -- The argument
2098             -> Type             -- The argument type
2099             -> LHsExpr RdrName  -- Boxed version of the arg
2100 -- See Note [Deriving and unboxed types]
2101 box_if_necy cls_str tycon arg arg_ty
2102   | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
2103   | otherwise             = arg
2104   where
2105     box_con = assoc_ty_id cls_str tycon boxConTbl arg_ty
2106
2107 ---------------------
2108 primOrdOps :: String    -- The class involved
2109            -> TyCon     -- The tycon involved
2110            -> Type      -- The type
2111            -> (RdrName, RdrName, RdrName, RdrName, RdrName)  -- (lt,le,eq,ge,gt)
2112 -- See Note [Deriving and unboxed types]
2113 primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty
2114
2115 ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
2116 ordOpTbl
2117  =  [(charPrimTy  , (ltChar_RDR  , leChar_RDR  , eqChar_RDR  , geChar_RDR  , gtChar_RDR  ))
2118     ,(intPrimTy   , (ltInt_RDR   , leInt_RDR   , eqInt_RDR   , geInt_RDR   , gtInt_RDR   ))
2119     ,(wordPrimTy  , (ltWord_RDR  , leWord_RDR  , eqWord_RDR  , geWord_RDR  , gtWord_RDR  ))
2120     ,(addrPrimTy  , (ltAddr_RDR  , leAddr_RDR  , eqAddr_RDR  , geAddr_RDR  , gtAddr_RDR  ))
2121     ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR , eqFloat_RDR , geFloat_RDR , gtFloat_RDR ))
2122     ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR, eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ]
2123
2124 boxConTbl :: [(Type, RdrName)]
2125 boxConTbl
2126   = [(charPrimTy  , getRdrName charDataCon  )
2127     ,(intPrimTy   , getRdrName intDataCon   )
2128     ,(wordPrimTy  , getRdrName wordDataCon  )
2129     ,(floatPrimTy , getRdrName floatDataCon )
2130     ,(doublePrimTy, getRdrName doubleDataCon)
2131     ]
2132
2133 assoc_ty_id :: String           -- The class involved
2134             -> TyCon            -- The tycon involved
2135             -> [(Type,a)]       -- The table
2136             -> Type             -- The type
2137             -> a                -- The result of the lookup
2138 assoc_ty_id cls_str _ tbl ty
2139   | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
2140                                               text "for primitive type" <+> ppr ty)
2141   | otherwise = head res
2142   where
2143     res = [id | (ty',id) <- tbl, ty `eqType` ty']
2144
2145 -----------------------------------------------------------------------
2146
2147 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2148 and_Expr a b = genOpApp a and_RDR    b
2149
2150 -----------------------------------------------------------------------
2151
2152 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2153 eq_Expr tycon ty a b
2154     | not (isUnLiftedType ty) = genOpApp a eq_RDR b
2155     | otherwise               = genPrimOpApp a prim_eq b
2156  where
2157    (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
2158 \end{code}
2159
2160 \begin{code}
2161 untag_Expr :: TyCon -> [( RdrName,  RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
2162 untag_Expr _ [] expr = expr
2163 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
2164   = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
2165       [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
2166
2167 enum_from_to_Expr
2168         :: LHsExpr RdrName -> LHsExpr RdrName
2169         -> LHsExpr RdrName
2170 enum_from_then_to_Expr
2171         :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2172         -> LHsExpr RdrName
2173
2174 enum_from_to_Expr      f   t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
2175 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
2176
2177 showParen_Expr
2178         :: LHsExpr RdrName -> LHsExpr RdrName
2179         -> LHsExpr RdrName
2180
2181 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
2182
2183 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
2184
2185 nested_compose_Expr []  = panic "nested_compose_expr"   -- Arg is always non-empty
2186 nested_compose_Expr [e] = parenify e
2187 nested_compose_Expr (e:es)
2188   = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
2189
2190 -- impossible_Expr is used in case RHSs that should never happen.
2191 -- We generate these to keep the desugarer from complaining that they *might* happen!
2192 error_Expr :: String -> LHsExpr RdrName
2193 error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
2194
2195 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
2196 -- method. It is currently only used by Enum.{succ,pred}
2197 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
2198 illegal_Expr meth tp msg =
2199    nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
2200
2201 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
2202 -- to include the value of a_RDR in the error string.
2203 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
2204 illegal_toEnum_tag tp maxtag =
2205    nlHsApp (nlHsVar error_RDR)
2206            (nlHsApp (nlHsApp (nlHsVar append_RDR)
2207                        (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
2208                     (nlHsApp (nlHsApp (nlHsApp
2209                            (nlHsVar showsPrec_RDR)
2210                            (nlHsIntLit 0))
2211                            (nlHsVar a_RDR))
2212                            (nlHsApp (nlHsApp
2213                                (nlHsVar append_RDR)
2214                                (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
2215                                (nlHsApp (nlHsApp (nlHsApp
2216                                         (nlHsVar showsPrec_RDR)
2217                                         (nlHsIntLit 0))
2218                                         (nlHsVar maxtag))
2219                                         (nlHsLit (mkHsString ")"))))))
2220
2221 parenify :: LHsExpr RdrName -> LHsExpr RdrName
2222 parenify e@(L _ (HsVar _)) = e
2223 parenify e                 = mkHsPar e
2224
2225 -- genOpApp wraps brackets round the operator application, so that the
2226 -- renamer won't subsequently try to re-associate it.
2227 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2228 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
2229
2230 genPrimOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2231 genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2))
2232 \end{code}
2233
2234 \begin{code}
2235 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
2236     :: RdrName
2237 a_RDR           = mkVarUnqual (fsLit "a")
2238 b_RDR           = mkVarUnqual (fsLit "b")
2239 c_RDR           = mkVarUnqual (fsLit "c")
2240 d_RDR           = mkVarUnqual (fsLit "d")
2241 f_RDR           = mkVarUnqual (fsLit "f")
2242 k_RDR           = mkVarUnqual (fsLit "k")
2243 z_RDR           = mkVarUnqual (fsLit "z")
2244 ah_RDR          = mkVarUnqual (fsLit "a#")
2245 bh_RDR          = mkVarUnqual (fsLit "b#")
2246 ch_RDR          = mkVarUnqual (fsLit "c#")
2247 dh_RDR          = mkVarUnqual (fsLit "d#")
2248
2249 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
2250 as_RDRs         = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
2251 bs_RDRs         = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
2252 cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
2253
2254 a_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
2255     false_Expr, true_Expr, fmap_Expr, pure_Expr, mempty_Expr, foldMap_Expr, traverse_Expr :: LHsExpr RdrName
2256 a_Expr          = nlHsVar a_RDR
2257 -- b_Expr       = nlHsVar b_RDR
2258 c_Expr          = nlHsVar c_RDR
2259 f_Expr          = nlHsVar f_RDR
2260 z_Expr          = nlHsVar z_RDR
2261 ltTag_Expr      = nlHsVar ltTag_RDR
2262 eqTag_Expr      = nlHsVar eqTag_RDR
2263 gtTag_Expr      = nlHsVar gtTag_RDR
2264 false_Expr      = nlHsVar false_RDR
2265 true_Expr       = nlHsVar true_RDR
2266 fmap_Expr       = nlHsVar fmap_RDR
2267 pure_Expr       = nlHsVar pure_RDR
2268 mempty_Expr     = nlHsVar mempty_RDR
2269 foldMap_Expr    = nlHsVar foldMap_RDR
2270 traverse_Expr   = nlHsVar traverse_RDR
2271
2272 a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName
2273 a_Pat           = nlVarPat a_RDR
2274 b_Pat           = nlVarPat b_RDR
2275 c_Pat           = nlVarPat c_RDR
2276 d_Pat           = nlVarPat d_RDR
2277 f_Pat           = nlVarPat f_RDR
2278 k_Pat           = nlVarPat k_RDR
2279 z_Pat           = nlVarPat z_RDR
2280
2281 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
2282 -- Generates Orig s RdrName, for the binding positions
2283 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
2284 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
2285 maxtag_RDR  tycon = mk_tc_deriv_name tycon mkMaxTagOcc
2286
2287 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
2288 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
2289
2290 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
2291 mkAuxBinderName parent occ_fun = mkRdrUnqual (occ_fun (nameOccName parent))
2292 -- Was: mkDerivedRdrName name occ_fun, which made an original name
2293 -- But:  (a) that does not work well for standalone-deriving
2294 --       (b) an unqualified name is just fine, provided it can't clash with user code
2295
2296 minusInt_RDR, tagToEnum_RDR, error_RDR :: RdrName
2297 minusInt_RDR  = getRdrName (primOpId IntSubOp   )
2298 tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)
2299 error_RDR     = getRdrName eRROR_ID
2300 \end{code}