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