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