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