TcGenDeriv.lhs 86.5 KB
Newer Older
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
9
10
11
12
13

This module is nominally ``subordinate'' to @TcDeriv@, which is the
``official'' interface to deriving-related things.

This is where we do all the grimy bindings' generation.

\begin{code}
14
15
{-# LANGUAGE ScopedTypeVariables #-}

16
module TcGenDeriv (
17
18
19
20
21
22
23
24
25
26
        BagDerivStuff, DerivStuff(..),

        gen_Bounded_binds,
        gen_Enum_binds,
        gen_Eq_binds,
        gen_Ix_binds,
        gen_Ord_binds,
        gen_Read_binds,
        gen_Show_binds,
        gen_Data_binds,
27
        gen_old_Typeable_binds, gen_Typeable_binds,
28
29
30
31
32
33
        gen_Functor_binds,
        FFoldType(..), functorLikeTraverse,
        deepSubtypesContaining, foldDataConArgs,
        gen_Foldable_binds,
        gen_Traversable_binds,
        genAuxBinds,
dreixel's avatar
dreixel committed
34
        ordOpTbl, boxConTbl
35
    ) where
36

37
#include "HsVersions.h"
38

39
import HsSyn
40
41
42
43
import RdrName
import BasicTypes
import DataCon
import Name
44

45
import DynFlags
46
import HscTypes
47
import PrelInfo
48
import FamInstEnv( FamInst )
49
import MkCore ( eRROR_ID )
50
import PrelNames hiding (error_RDR)
51
52
53
import PrimOp
import SrcLoc
import TyCon
54
import CoAxiom
55
56
57
import TcType
import TysPrim
import TysWiredIn
58
59
60
import Type
import TypeRep
import VarSet
61
import Module
62
import State
63
import Util
64
import MonadUtils
65
import Outputable
66
import FastString
67
import Bag
68
import Fingerprint
69
import TcEnv (InstInfo)
70

71
import Data.List ( partition, intersperse )
72
73
\end{code}

74
\begin{code}
75
76
type BagDerivStuff = Bag DerivStuff

77
data AuxBindSpec
78
79
80
  = DerivCon2Tag TyCon  -- The con2Tag for given TyCon
  | DerivTag2Con TyCon  -- ...ditto tag2Con
  | DerivMaxTag  TyCon  -- ...and maxTag
81
  deriving( Eq )
82
83
84
  -- All these generate ZERO-BASED tag operations
  -- I.e first constructor has tag 0

85
86
87
data DerivStuff     -- Please add this auxiliary stuff
  = DerivAuxBind AuxBindSpec

88
  -- Generics
89
90
  | DerivTyCon TyCon                   -- New data types
  | DerivFamInst (FamInst Unbranched)  -- New type family instances
91

92
  -- New top-level auxiliary bindings
dreixel's avatar
dreixel committed
93
94
  | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB
  | DerivInst (InstInfo RdrName)                -- New, auxiliary instances
95
96
\end{code}

97
98

%************************************************************************
99
100
101
%*                                                                      *
                Eq instances
%*                                                                      *
102
103
%************************************************************************

104
105
106
107
108
109
110
111
112
Here are the heuristics for the code we generate for @Eq@. Let's
assume we have a data type with some (possibly zero) nullary data
constructors and some ordinary, non-nullary ones (the rest, also
possibly zero of them).  Here's an example, with both \tr{N}ullary and
\tr{O}rdinary data cons.

  data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...

* For the ordinary constructors (if any), we emit clauses to do The
113
114
  Usual Thing, e.g.,:

115
116
117
118
119
120
121
    (==) (O1 a1 b1)    (O1 a2 b2)    = a1 == a2 && b1 == b2
    (==) (O2 a1)       (O2 a2)       = a1 == a2
    (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2

  Note: if we're comparing unlifted things, e.g., if 'a1' and
  'a2' are Float#s, then we have to generate
       case (a1 `eqFloat#` a2) of r -> r
122
123
  for that particular test.

124
125
* If there are a lot of (more than en) nullary constructors, we emit a
  catch-all clause of the form:
126

127
128
129
130
      (==) a b  = case (con2tag_Foo a) of { a# ->
                  case (con2tag_Foo b) of { b# ->
                  case (a# ==# b#)     of {
                    r -> r }}}
131

132
133
134
135
136
  If con2tag gets inlined this leads to join point stuff, so
  it's better to use regular pattern matching if there aren't too
  many nullary constructors.  "Ten" is arbitrary, of course

* If there aren't any nullary constructors, we emit a simpler
137
138
  catch-all:

139
     (==) a b  = False
140

141
* For the @(/=)@ method, we normally just use the default method.
142
143
144
145
  If the type is an enumeration type, we could/may/should? generate
  special code that calls @con2tag_Foo@, much like for @(==)@ shown
  above.

146
147
148
149
150
151
152
153
We thought about doing this: If we're also deriving 'Ord' for this
tycon, we generate:
  instance ... Eq (Foo ...) where
    (==) a b  = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
    (/=) a b  = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
However, that requires that (Ord <whatever>) was put in the context
for the instance decl, which it probably wasn't, so the decls
produced don't get through the typechecker.
sof's avatar
sof committed
154

155
\begin{code}
dreixel's avatar
dreixel committed
156
gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
157
gen_Eq_binds loc tycon
dreixel's avatar
dreixel committed
158
  = (method_binds, aux_binds)
159
  where
160
161
162
163
164
165
166
167
168
    all_cons = tyConDataCons tycon
    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons

    -- If there are ten or more (arbitrary number) nullary constructors,
    -- use the con2tag stuff.  For small types it's better to use
    -- ordinary pattern matching.
    (tag_match_cons, pat_match_cons)
       | nullary_cons `lengthExceeds` 10 = (nullary_cons, non_nullary_cons)
       | otherwise                       = ([],           all_cons)
169

170
    no_tag_match_cons = null tag_match_cons
171

172
    fall_through_eqn
173
174
      | no_tag_match_cons   -- All constructors have arguments
      = case pat_match_cons of
175
          []  -> []   -- No constructors; no fall-though case
176
          [_] -> []   -- One constructor; no fall-though case
177
          _   ->      -- Two or more constructors; add fall-through of
178
179
                      --       (==) _ _ = False
                 [([nlWildPat, nlWildPat], false_Expr)]
180

181
      | otherwise -- One or more tag_match cons; add fall-through of
182
183
                  -- extract tags compare for equality
      = [([a_Pat, b_Pat],
184
185
         untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
                    (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
186

187
188
    aux_binds | no_tag_match_cons = emptyBag
              | otherwise         = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
189

dreixel's avatar
dreixel committed
190
    method_binds = listToBag [eq_bind, ne_bind]
191
    eq_bind = mk_FunBind loc eq_RDR (map pats_etc pat_match_cons ++ fall_through_eqn)
192
    ne_bind = mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
193
                        nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
194

195
196
197
    ------------------------------------------------------------------
    pats_etc data_con
      = let
198
199
200
201
202
203
204
205
206
207
            con1_pat = nlConVarPat data_con_RDR as_needed
            con2_pat = nlConVarPat data_con_RDR bs_needed

            data_con_RDR = getRdrName data_con
            con_arity   = length tys_needed
            as_needed   = take con_arity as_RDRs
            bs_needed   = take con_arity bs_RDRs
            tys_needed  = dataConOrigArgTys data_con
        in
        ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
208
      where
209
210
211
212
213
        nested_eq_expr []  [] [] = true_Expr
        nested_eq_expr tys as bs
          = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
          where
            nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
214
215
216
\end{code}

%************************************************************************
217
218
219
%*                                                                      *
        Ord instances
%*                                                                      *
220
221
%************************************************************************

222
223
Note [Generating Ord instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
224
Suppose constructors are K1..Kn, and some are nullary.
225
226
227
The general form we generate is:

* Do case on first argument
228
        case a of
229
230
231
232
233
234
235
          K1 ... -> rhs_1
          K2 ... -> rhs_2
          ...
          Kn ... -> rhs_n
          _ -> nullary_rhs

* To make rhs_i
236
237
     If i = 1, 2, n-1, n, generate a single case.
        rhs_2    case b of
238
239
240
241
242
243
244
245
                   K1 {}  -> LT
                   K2 ... -> ...eq_rhs(K2)...
                   _      -> GT

     Otherwise do a tag compare against the bigger range
     (because this is the one most likely to succeed)
        rhs_3    case tag b of tb ->
                 if 3 <# tg then GT
246
                 else case b of
247
248
249
                         K3 ... -> ...eq_rhs(K3)....
                         _      -> LT

250
* To make eq_rhs(K), which knows that
251
252
253
254
255
256
    a = K a1 .. av
    b = K b1 .. bv
  we just want to compare (a1,b1) then (a2,b2) etc.
  Take care on the last field to tail-call into comparing av,bv

* To make nullary_rhs generate this
257
258
     case con2tag a of a# ->
     case con2tag b of ->
259
260
261
262
263
264
265
     a# `compare` b#

Several special cases:

* Two or fewer nullary constructors: don't generate nullary_rhs

* Be careful about unlifted comparisons.  When comparing unboxed
266
  values we can't call the overloaded functions.
267
268
269
270
271
272
273
274
275
276
  See function unliftedOrdOp

Note [Do not rely on compare]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's a bad idea to define only 'compare', and build the other binary
comparisions on top of it; see Trac #2130, #4019.  Reason: we don't
want to laboriously make a three-way comparison, only to extract a
binary result, something like this:
     (>) (I# x) (I# y) = case <# x y of
                            True -> False
277
                            False -> case ==# x y of
278
279
                                       True  -> False
                                       False -> True
280

281
So for sufficiently small types (few constructors, or all nullary)
282
we generate all methods; for large ones we just use 'compare'.
283

284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
\begin{code}
data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT

------------
ordMethRdr :: OrdOp -> RdrName
ordMethRdr op
  = case op of
       OrdCompare -> compare_RDR
       OrdLT      -> lt_RDR
       OrdLE      -> le_RDR
       OrdGE      -> ge_RDR
       OrdGT      -> gt_RDR

------------
ltResult :: OrdOp -> LHsExpr RdrName
-- Knowing a<b, what is the result for a `op` b?
ltResult OrdCompare = ltTag_Expr
ltResult OrdLT      = true_Expr
ltResult OrdLE      = true_Expr
ltResult OrdGE      = false_Expr
ltResult OrdGT      = false_Expr

------------
eqResult :: OrdOp -> LHsExpr RdrName
-- Knowing a=b, what is the result for a `op` b?
eqResult OrdCompare = eqTag_Expr
eqResult OrdLT      = false_Expr
eqResult OrdLE      = true_Expr
eqResult OrdGE      = true_Expr
eqResult OrdGT      = false_Expr

------------
gtResult :: OrdOp -> LHsExpr RdrName
-- Knowing a>b, what is the result for a `op` b?
gtResult OrdCompare = gtTag_Expr
gtResult OrdLT      = false_Expr
gtResult OrdLE      = false_Expr
gtResult OrdGE      = true_Expr
gtResult OrdGT      = true_Expr

------------
dreixel's avatar
dreixel committed
325
gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
326
gen_Ord_binds loc tycon
327
  | null tycon_data_cons        -- No data-cons => invoke bale-out case
dreixel's avatar
dreixel committed
328
  = (unitBag $ mk_FunBind loc compare_RDR [], emptyBag)
329
  | otherwise
dreixel's avatar
dreixel committed
330
  = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
331
  where
332
    aux_binds | single_con_type = emptyBag
333
              | otherwise       = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
334

335
336
337
        -- Note [Do not rely on compare]
    other_ops | (last_tag - first_tag) <= 2     -- 1-3 constructors
                || null non_nullary_cons        -- Or it's an enumeration
338
              = listToBag (map mkOrdOp [OrdLT,OrdLE,OrdGE,OrdGT])
339
              | otherwise
340
              = emptyBag
341

342
343
344
    get_tag con = dataConTag con - fIRST_TAG
        -- We want *zero-based* tags, because that's what
        -- con2Tag returns (generated by untag_Expr)!
345

346
347
348
349
    tycon_data_cons = tyConDataCons tycon
    single_con_type = isSingleton tycon_data_cons
    (first_con : _) = tycon_data_cons
    (last_con : _)  = reverse tycon_data_cons
350
351
    first_tag       = get_tag first_con
    last_tag        = get_tag last_con
352

353
    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
354

355

dreixel's avatar
dreixel committed
356
    mkOrdOp :: OrdOp -> LHsBind RdrName
357
    -- Returns a binding   op a b = ... compares a and b according to op ....
dreixel's avatar
dreixel committed
358
    mkOrdOp op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] (mkOrdOpRhs op)
359

360
    mkOrdOpRhs :: OrdOp -> LHsExpr RdrName
361
    mkOrdOpRhs op       -- RHS for comparing 'a' and 'b' according to op
362
      | length nullary_cons <= 2  -- Two nullary or fewer, so use cases
363
      = nlHsCase (nlHsVar a_RDR) $
364
        map (mkOrdOpAlt op) tycon_data_cons
365
        -- i.e.  case a of { C1 x y -> case b of C1 x y -> ....compare x,y...
366
        --                   C2 x   -> case b of C2 x -> ....comopare x.... }
367

368
369
      | null non_nullary_cons    -- All nullary, so go straight to comparing tags
      = mkTagCmp op
370

371
      | otherwise                -- Mixed nullary and non-nullary
372
      = nlHsCase (nlHsVar a_RDR) $
373
        (map (mkOrdOpAlt op) non_nullary_cons
374
         ++ [mkSimpleHsAlt nlWildPat (mkTagCmp op)])
375

376

377
    mkOrdOpAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
378
    -- Make the alternative  (Ki a1 a2 .. av ->
379
380
381
382
383
384
385
386
387
388
389
390
391
    mkOrdOpAlt op data_con
      = mkSimpleHsAlt (nlConVarPat data_con_RDR as_needed) (mkInnerRhs op data_con)
      where
        as_needed    = take (dataConSourceArity data_con) as_RDRs
        data_con_RDR = getRdrName data_con

    mkInnerRhs op data_con
      | single_con_type
      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ]

      | tag == first_tag
      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
                                 , mkSimpleHsAlt nlWildPat (ltResult op) ]
392
      | tag == last_tag
393
394
      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
                                 , mkSimpleHsAlt nlWildPat (gtResult op) ]
395

396
397
398
399
400
401
402
403
404
      | tag == first_tag + 1
      = nlHsCase (nlHsVar b_RDR) [ mkSimpleHsAlt (nlConWildPat first_con) (gtResult op)
                                 , mkInnerEqAlt op data_con
                                 , mkSimpleHsAlt nlWildPat (ltResult op) ]
      | tag == last_tag - 1
      = nlHsCase (nlHsVar b_RDR) [ mkSimpleHsAlt (nlConWildPat last_con) (ltResult op)
                                 , mkInnerEqAlt op data_con
                                 , mkSimpleHsAlt nlWildPat (gtResult op) ]

405
      | tag > last_tag `div` 2  -- lower range is larger
406
407
      = untag_Expr tycon [(b_RDR, bh_RDR)] $
        nlHsIf (genOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
408
               (gtResult op) $  -- Definitely GT
409
410
        nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
                                 , mkSimpleHsAlt nlWildPat (ltResult op) ]
411
412

      | otherwise               -- upper range is larger
413
414
      = untag_Expr tycon [(b_RDR, bh_RDR)] $
        nlHsIf (genOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
415
               (ltResult op) $  -- Definitely LT
416
417
418
        nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
                                 , mkSimpleHsAlt nlWildPat (gtResult op) ]
      where
419
        tag     = get_tag data_con
420
421
        tag_lit = noLoc (HsLit (HsIntPrim (toInteger tag)))

422
    mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
423
424
425
426
    -- First argument 'a' known to be built with K
    -- Returns a case alternative  Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...)
    mkInnerEqAlt op data_con
      = mkSimpleHsAlt (nlConVarPat data_con_RDR bs_needed) $
427
        mkCompareFields tycon op (dataConOrigArgTys data_con)
428
429
430
431
      where
        data_con_RDR = getRdrName data_con
        bs_needed    = take (dataConSourceArity data_con) bs_RDRs

432
    mkTagCmp :: OrdOp -> LHsExpr RdrName
433
434
435
436
    -- Both constructors known to be nullary
    -- genreates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#
    mkTagCmp op = untag_Expr tycon [(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $
                  unliftedOrdOp tycon intPrimTy op ah_RDR bh_RDR
437

438
439
440
441
442
443
444
445
446
447
mkCompareFields :: TyCon -> OrdOp -> [Type] -> LHsExpr RdrName
-- Generates nested comparisons for (a1,a2...) against (b1,b2,...)
-- where the ai,bi have the given types
mkCompareFields tycon op tys
  = go tys as_RDRs bs_RDRs
  where
    go []   _      _          = eqResult op
    go [ty] (a:_)  (b:_)
      | isUnLiftedType ty     = unliftedOrdOp tycon ty op a b
      | otherwise             = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)
448
449
    go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
                                  (ltResult op)
450
                                  (go tys as bs)
451
                                  (gtResult op)
452
453
454
455
    go _ _ _ = panic "mkCompareFields"

    -- (mk_compare ty a b) generates
    --    (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })
456
    -- but with suitable special cases for
457
458
459
    mk_compare ty a b lt eq gt
      | isUnLiftedType ty
      = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
460
      | otherwise
461
462
463
464
465
466
467
468
469
470
471
472
      = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr))
          [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) lt,
           mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
           mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gt]
      where
        a_expr = nlHsVar a
        b_expr = nlHsVar b
        (lt_op, _, eq_op, _, _) = primOrdOps "Ord" tycon ty

unliftedOrdOp :: TyCon -> Type -> OrdOp -> RdrName -> RdrName -> LHsExpr RdrName
unliftedOrdOp tycon ty op a b
  = case op of
473
       OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
474
475
476
477
478
479
480
                                     ltTag_Expr eqTag_Expr gtTag_Expr
       OrdLT      -> wrap lt_op
       OrdLE      -> wrap le_op
       OrdGE      -> wrap ge_op
       OrdGT      -> wrap gt_op
  where
   (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" tycon ty
481
   wrap prim_op = genOpApp a_expr (primOpRdrName prim_op) b_expr
482
483
484
   a_expr = nlHsVar a
   b_expr = nlHsVar b

485
486
unliftedCompare :: PrimOp -> PrimOp
                -> LHsExpr RdrName -> LHsExpr RdrName   -- What to cmpare
487
488
489
490
491
                -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName  -- Three results
                -> LHsExpr RdrName
-- Return (if a < b then lt else if a == b then eq else gt)
unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
  = nlHsIf (genOpApp a_expr (primOpRdrName lt_op) b_expr) lt $
Gabor Greif's avatar
typos    
Gabor Greif committed
492
                        -- Test (<) first, not (==), because the latter
493
494
                        -- is true less often, so putting it first would
                        -- mean more tests (dynamically)
495
496
497
498
499
        nlHsIf (genOpApp a_expr (primOpRdrName eq_op) b_expr) eq gt

nlConWildPat :: DataCon -> LPat RdrName
-- The pattern (K {})
nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con))
500
                                   (RecCon (HsRecFields { rec_flds = []
501
                                                        , rec_dotdot = Nothing })))
502
503
\end{code}

504

505

506
%************************************************************************
507
508
509
%*                                                                      *
        Enum instances
%*                                                                      *
510
511
512
513
514
515
516
517
518
519
520
521
%************************************************************************

@Enum@ can only be derived for enumeration types.  For a type
\begin{verbatim}
data Foo ... = N1 | N2 | ... | Nn
\end{verbatim}

we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
@maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).

\begin{verbatim}
instance ... Enum (Foo ...) where
sof's avatar
sof committed
522
523
524
    succ x   = toEnum (1 + fromEnum x)
    pred x   = toEnum (fromEnum x - 1)

525
526
    toEnum i = tag2con_Foo i

527
528
529
530
531
    enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]

    -- or, really...
    enumFrom a
      = case con2tag_Foo a of
532
          a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
533
534
535
536
537
538
539

   enumFromThen a b
     = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]

    -- or, really...
    enumFromThen a b
      = case con2tag_Foo a of { a# ->
540
541
542
        case con2tag_Foo b of { b# ->
        map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
        }}
543
544
545
546
547
\end{verbatim}

For @enumFromTo@ and @enumFromThenTo@, we use the default methods.

\begin{code}
dreixel's avatar
dreixel committed
548
gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
549
gen_Enum_binds loc tycon
dreixel's avatar
dreixel committed
550
  = (method_binds, aux_binds)
551
  where
dreixel's avatar
dreixel committed
552
    method_binds = listToBag [
553
554
555
556
557
558
559
                        succ_enum,
                        pred_enum,
                        to_enum,
                        enum_from,
                        enum_from_then,
                        from_enum
                    ]
560
561
    aux_binds = listToBag $ map DerivAuxBind
                  [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
562

563
    occ_nm = getOccString tycon
sof's avatar
sof committed
564
565

    succ_enum
566
      = mk_easy_FunBind loc succ_RDR [a_Pat] $
567
568
569
570
571
572
573
574
        untag_Expr tycon [(a_RDR, ah_RDR)] $
        nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
                               nlHsVarApps intDataCon_RDR [ah_RDR]])
             (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
             (nlHsApp (nlHsVar (tag2con_RDR tycon))
                    (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
                                        nlHsIntLit 1]))

sof's avatar
sof committed
575
    pred_enum
576
      = mk_easy_FunBind loc pred_RDR [a_Pat] $
577
578
579
580
581
582
583
        untag_Expr tycon [(a_RDR, ah_RDR)] $
        nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
                               nlHsVarApps intDataCon_RDR [ah_RDR]])
             (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
             (nlHsApp (nlHsVar (tag2con_RDR tycon))
                           (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
                                               nlHsLit (HsInt (-1))]))
584
585

    to_enum
586
      = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
587
588
        nlHsIf (nlHsApps and_RDR
                [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
589
590
                 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
             (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
591
             (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
592

593
    enum_from
594
      = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
595
596
597
598
599
600
          untag_Expr tycon [(a_RDR, ah_RDR)] $
          nlHsApps map_RDR
                [nlHsVar (tag2con_RDR tycon),
                 nlHsPar (enum_from_to_Expr
                            (nlHsVarApps intDataCon_RDR [ah_RDR])
                            (nlHsVar (maxtag_RDR tycon)))]
601
602

    enum_from_then
603
      = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
604
605
606
607
608
609
610
611
612
613
          untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
          nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
            nlHsPar (enum_from_then_to_Expr
                    (nlHsVarApps intDataCon_RDR [ah_RDR])
                    (nlHsVarApps intDataCon_RDR [bh_RDR])
                    (nlHsIf  (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
                                               nlHsVarApps intDataCon_RDR [bh_RDR]])
                           (nlHsIntLit 0)
                           (nlHsVar (maxtag_RDR tycon))
                           ))
614
615

    from_enum
616
      = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
617
618
          untag_Expr tycon [(a_RDR, ah_RDR)] $
          (nlHsVarApps intDataCon_RDR [ah_RDR])
619
620
\end{code}

621
%************************************************************************
622
623
624
%*                                                                      *
        Bounded instances
%*                                                                      *
625
626
627
%************************************************************************

\begin{code}
dreixel's avatar
dreixel committed
628
gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
629
gen_Bounded_binds loc tycon
630
  | isEnumerationTyCon tycon
dreixel's avatar
dreixel committed
631
  = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
632
633
  | otherwise
  = ASSERT(isSingleton data_cons)
dreixel's avatar
dreixel committed
634
    (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)
635
  where
636
    data_cons = tyConDataCons tycon
637
638

    ----- enum-flavored: ---------------------------
639
640
    min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
    max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
641

642
643
    data_con_1     = head data_cons
    data_con_N     = last data_cons
644
645
    data_con_1_RDR = getRdrName data_con_1
    data_con_N_RDR = getRdrName data_con_N
646
647

    ----- single-constructor-flavored: -------------
648
    arity          = dataConSourceArity data_con_1
649

650
    min_bound_1con = mkHsVarBind loc minBound_RDR $
651
                     nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
652
    max_bound_1con = mkHsVarBind loc maxBound_RDR $
653
                     nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
654
655
656
\end{code}

%************************************************************************
657
658
659
%*                                                                      *
        Ix instances
%*                                                                      *
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
%************************************************************************

Deriving @Ix@ is only possible for enumeration types and
single-constructor types.  We deal with them in turn.

For an enumeration type, e.g.,
\begin{verbatim}
    data Foo ... = N1 | N2 | ... | Nn
\end{verbatim}
things go not too differently from @Enum@:
\begin{verbatim}
instance ... Ix (Foo ...) where
    range (a, b)
      = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]

    -- or, really...
    range (a, b)
      = case (con2tag_Foo a) of { a# ->
678
679
680
        case (con2tag_Foo b) of { b# ->
        map tag2con_Foo (enumFromTo (I# a#) (I# b#))
        }}
681

Gabor Greif's avatar
typos    
Gabor Greif committed
682
    -- Generate code for unsafeIndex, because using index leads
683
684
685
    -- to lots of redundant range tests
    unsafeIndex c@(a, b) d
      = case (con2tag_Foo d -# con2tag_Foo a) of
686
               r# -> I# r#
687
688
689

    inRange (a, b) c
      = let
690
691
692
            p_tag = con2tag_Foo c
        in
        p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
693
694
695
696

    -- or, really...
    inRange (a, b) c
      = case (con2tag_Foo a)   of { a_tag ->
697
698
699
700
701
702
703
        case (con2tag_Foo b)   of { b_tag ->
        case (con2tag_Foo c)   of { c_tag ->
        if (c_tag >=# a_tag) then
          c_tag <=# b_tag
        else
          False
        }}}
704
\end{verbatim}
705
(modulo suitable case-ification to handle the unlifted tags)
706
707
708
709
710
711
712
713
714

For a single-constructor type (NB: this includes all tuples), e.g.,
\begin{verbatim}
    data Foo ... = MkFoo a b Int Double c c
\end{verbatim}
we follow the scheme given in Figure~19 of the Haskell~1.2 report
(p.~147).

\begin{code}
dreixel's avatar
dreixel committed
715
gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
716

717
gen_Ix_binds loc tycon
718
  | isEnumerationTyCon tycon
719
720
721
  = ( enum_ixes
    , listToBag $ map DerivAuxBind
                   [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
722
  | otherwise
723
  = (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))
724
725
  where
    --------------------------------------------------------------
dreixel's avatar
dreixel committed
726
    enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
727
728

    enum_range
729
      = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
730
731
732
733
734
735
          untag_Expr tycon [(a_RDR, ah_RDR)] $
          untag_Expr tycon [(b_RDR, bh_RDR)] $
          nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
              nlHsPar (enum_from_to_Expr
                        (nlHsVarApps intDataCon_RDR [ah_RDR])
                        (nlHsVarApps intDataCon_RDR [bh_RDR]))
736
737

    enum_index
738
739
740
741
742
743
744
745
746
747
748
749
750
751
      = mk_easy_FunBind loc unsafeIndex_RDR
                [noLoc (AsPat (noLoc c_RDR)
                           (nlTuplePat [a_Pat, nlWildPat] Boxed)),
                                d_Pat] (
           untag_Expr tycon [(a_RDR, ah_RDR)] (
           untag_Expr tycon [(d_RDR, dh_RDR)] (
           let
                rhs = nlHsVarApps intDataCon_RDR [c_RDR]
           in
           nlHsCase
             (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
             [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
           ))
        )
752
753

    enum_inRange
754
      = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
755
756
757
758
759
760
761
762
          untag_Expr tycon [(a_RDR, ah_RDR)] (
          untag_Expr tycon [(b_RDR, bh_RDR)] (
          untag_Expr tycon [(c_RDR, ch_RDR)] (
          nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
             (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
          ) {-else-} (
             false_Expr
          ))))
763
764

    --------------------------------------------------------------
765
    single_con_ixes
dreixel's avatar
dreixel committed
766
      = listToBag [single_con_range, single_con_index, single_con_inRange]
767
768

    data_con
769
770
771
      = case tyConSingleDataCon_maybe tycon of -- just checking...
          Nothing -> panic "get_Ix_binds"
          Just dc -> dc
772

773
    con_arity    = dataConSourceArity data_con
774
    data_con_RDR = getRdrName data_con
775

776
777
778
    as_needed = take con_arity as_RDRs
    bs_needed = take con_arity bs_RDRs
    cs_needed = take con_arity cs_RDRs
779

780
781
    con_pat  xs  = nlConVarPat data_con_RDR xs
    con_expr     = nlHsVarApps data_con_RDR cs_needed
sof's avatar
sof committed
782

783
784
    --------------------------------------------------------------
    single_con_range
785
786
787
      = mk_easy_FunBind loc range_RDR
          [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
        noLoc (mkHsComp ListComp stmts con_expr)
788
      where
789
        stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
790

791
792
793
        mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
                                 (nlHsApp (nlHsVar range_RDR)
                                          (mkLHsVarTuple [a,b]))
794
795
796

    ----------------
    single_con_index
797
798
799
      = mk_easy_FunBind loc unsafeIndex_RDR
                [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
                 con_pat cs_needed]
800
801
802
803
        -- We need to reverse the order we consider the components in
        -- so that
        --     range (l,u) !! index (l,u) i == i   -- when i is in range
        -- (from http://haskell.org/onlinereport/ix.html) holds.
804
                (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
805
      where
806
807
808
809
810
811
812
813
814
815
816
817
818
819
        -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
        mk_index []        = nlHsIntLit 0
        mk_index [(l,u,i)] = mk_one l u i
        mk_index ((l,u,i) : rest)
          = genOpApp (
                mk_one l u i
            ) plus_RDR (
                genOpApp (
                    (nlHsApp (nlHsVar unsafeRangeSize_RDR)
                             (mkLHsVarTuple [l,u]))
                ) times_RDR (mk_index rest)
           )
        mk_one l u i
          = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i]
820
821
822

    ------------------
    single_con_inRange
823
824
825
826
      = mk_easy_FunBind loc inRange_RDR
                [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
                 con_pat cs_needed] $
          foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
827
      where
828
        in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
829
830
831
\end{code}

%************************************************************************
832
833
834
%*                                                                      *
        Read instances
%*                                                                      *
835
836
%************************************************************************

837
838
839
840
Example

  infix 4 %%
  data T = Int %% Int
841
842
         | T1 { f1 :: Int }
         | T2 T
843
844
845

instance Read T where
  readPrec =
846
    parens
847
    ( prec 4 (
848
849
850
        do x <- ReadP.step Read.readPrec
           expectP (Symbol "%%")
           y <- ReadP.step Read.readPrec
851
852
           return (x %% y))
      +++
853
      prec (appPrec+1) (
854
855
        -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
        -- Record construction binds even more tightly than application
856
857
858
859
        do expectP (Ident "T1")
           expectP (Punc '{')
           expectP (Ident "f1")
           expectP (Punc '=')
860
           x          <- ReadP.reset Read.readPrec
861
           expectP (Punc '}')
862
           return (T1 { f1 = x }))
863
864
      +++
      prec appPrec (
865
866
        do expectP (Ident "T2")
           x <- ReadP.step Read.readPrec
867
868
869
870
871
872
873
           return (T2 x))
    )

  readListPrec = readListPrecDefault
  readList     = readListDefault


874
875
876
877
878
879
880
881
882
883
Note [Use expectP]
~~~~~~~~~~~~~~~~~~
Note that we use 
   expectP (Ident "T1")
rather than
   Ident "T1" <- lexP
The latter desugares to inline code for matching the Ident and the
string, and this can be very voluminous. The former is much more
compact.  Cf Trac #7258, although that also concerned non-linearity in
the occurrence analyser, a separate issue.
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902

Note [Read for empty data types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
What should we get for this?  (Trac #7931)
   data Emp deriving( Read )   -- No data constructors

Here we want
  read "[]" :: [Emp]   to succeed, returning []
So we do NOT want 
   instance Read Emp where
     readPrec = error "urk"
Rather we want
   instance Read Emp where
     readPred = pfail   -- Same as choose []

Because 'pfail' allows the parser to backtrack, but 'error' doesn't.
These instances are also useful for Read (Either Int Emp), where 
we want to be able to parse (Left 3) just fine.

903
\begin{code}
dreixel's avatar
dreixel committed
904
gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
905

906
gen_Read_binds get_fixity loc tycon
dreixel's avatar
dreixel committed
907
  = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
908
  where
909
    -----------------------------------------------------------------------
910
911
    default_readlist
        = mkHsVarBind loc readList_RDR     (nlHsVar readListDefault_RDR)
912
913

    default_readlistprec
914
        = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
915
    -----------------------------------------------------------------------
916
917

    data_cons = tyConDataCons tycon
918
    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
919

920
    read_prec = mkHsVarBind loc readPrec_RDR
921
                              (nlHsApp (nlHsVar parens_RDR) read_cons)
922

923
    read_cons | null data_cons = nlHsVar pfail_RDR  -- See Note [Read for empty data types]
924
              | otherwise      = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
925
    read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
926
927

    read_nullary_cons
928
      = case nullary_cons of
929
930
931
932
            []    -> []
            [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])]
            _     -> [nlHsApp (nlHsVar choose_RDR)
                              (nlList (map mk_pair nullary_cons))]
933
        -- NB For operators the parens around (:=:) are matched by the
934
935
        -- enclosing "parens" call, so here we must match the naked
        -- data_con_str con
936

937
938
    match_con con | isSym con_str = [symbol_pat con_str]
                  | otherwise     = ident_h_pat  con_str
939
940
                  where
                    con_str = data_con_str con
941
942
        -- For nullary constructors we must match Ident s for normal constrs
        -- and   Symbol s   for operators
943

944
945
    mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),
                                  result_expr con []]
946

947
    read_non_nullary_con data_con
948
949
      | is_infix  = mk_parser infix_prec  infix_stmts  body
      | is_record = mk_parser record_prec record_stmts body
950
951
--              Using these two lines instead allows the derived
--              read for infix and record bindings to read the prefix form
952
953
954
--      | is_infix  = mk_alt prefix_parser (mk_parser infix_prec  infix_stmts  body)
--      | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
      | otherwise = prefix_parser
955
      where
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
        body = result_expr data_con as_needed
        con_str = data_con_str data_con

        prefix_parser = mk_parser prefix_prec prefix_stmts body

        read_prefix_con
            | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"]
            | otherwise     = ident_h_pat con_str

        read_infix_con
            | isSym con_str = [symbol_pat con_str]
            | otherwise     = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"]

        prefix_stmts            -- T a b c
          = read_prefix_con ++ read_args

        infix_stmts             -- a %% b, or  a `T` b
          = [read_a1]
            ++ read_infix_con
            ++ [read_a2]

        record_stmts            -- T { f1 = a, f2 = b }
          = read_prefix_con
            ++ [read_punc "{"]
            ++ concat (intersperse [read_punc ","] field_stmts)
            ++ [read_punc "}"]

        field_stmts  = zipWithEqual "lbl_stmts" read_field labels as_needed

        con_arity    = dataConSourceArity data_con
        labels       = dataConFieldLabels data_con
        dc_nm        = getName data_con
        is_infix     = dataConIsInfix data_con
        is_record    = length labels > 0
        as_needed    = take con_arity as_RDRs
        read_args    = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
        (read_a1:read_a2:_) = read_args

        prefix_prec = appPrecedence
        infix_prec  = getPrecedence get_fixity dc_nm
        record_prec = appPrecedence + 1 -- Record construction binds even more tightly
                                        -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
998
999

    ------------------------------------------------------------------------
1000
    --          Helpers
1001
    ------------------------------------------------------------------------
1002
1003
    mk_alt e1 e2       = genOpApp e1 alt_RDR e2                         -- e1 +++ e2
    mk_parser p ss b   = nlHsApps prec_RDR [nlHsIntLit p                -- prec p (do { ss ; b })
1004
                                           , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])]
1005
    con_app con as     = nlHsVarApps (getRdrName con) as                -- con as
1006
    result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
1007

1008
1009
1010
1011
1012
    -- For constructors and field labels ending in '#', we hackily
    -- let the lexer generate two tokens, and look for both in sequence
    -- Thus [Ident "I"; Symbol "#"].  See Trac #5041
    ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ]
                  | otherwise                    = [ ident_pat s ]
1013

1014
1015
1016
1017
1018
    bindLex pat  = noLoc (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat))  -- expectP p
                   -- See Note [Use expectP]
    ident_pat  s = bindLex $ nlHsApps ident_RDR  [nlHsLit (mkHsString s)]  -- expectP (Ident "foo")
    symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)]  -- expectP (Symbol ">>")
    read_punc c  = bindLex $ nlHsApps punc_RDR   [nlHsLit (mkHsString c)]  -- expectP (Punc "<")
1019

1020
    data_con_str con = occNameString (getOccName con)
1021

1022
1023
    read_arg a ty = ASSERT( not (isUnLiftedType ty) )
                    noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
1024

1025
    read_field lbl a = read_lbl lbl ++
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
                       [read_punc "=",
                        noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]

        -- When reading field labels we might encounter
        --      a  = 3
        --      _a = 3
        -- or   (#) = 4
        -- Note the parens!
    read_lbl lbl | isSym lbl_str
                 = [read_punc "(", symbol_pat lbl_str, read_punc ")"]
                 | otherwise
                 = ident_h_pat lbl_str
                 where
                   lbl_str = occNameString (getOccName lbl)
1040
\end{code}
1041

1042

1043
%************************************************************************
1044
1045
1046
%*                                                                      *
        Show instances
%*                                                                      *
1047
1048
%************************************************************************

1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
Example

    infixr 5 :^:

    data Tree a =  Leaf a  |  Tree a :^: Tree a

    instance (Show a) => Show (Tree a) where

        showsPrec d (Leaf m) = showParen (d > app_prec) showStr
          where
             showStr = showString "Leaf " . showsPrec (app_prec+1) m

        showsPrec d (u :^: v) = showParen (d > up_prec) showStr
          where
1063
             showStr = showsPrec (up_prec+1) u .
1064
1065
1066
1067
1068
1069
                       showString " :^: "      .
                       showsPrec (up_prec+1) v
                -- Note: right-associativity of :^: ignored

    up_prec  = 5    -- Precedence of :^:
    app_prec = 10   -- Application has precedence one more than
1070
                    -- the most tightly-binding operator
1071

1072
\begin{code}
dreixel's avatar
dreixel committed
1073
gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1074

1075
gen_Show_binds get_fixity loc tycon
dreixel's avatar
dreixel committed
1076
  = (listToBag [shows_prec, show_list], emptyBag)
1077
1078
  where
    -----------------------------------------------------------------------
1079
    show_list = mkHsVarBind loc showList_RDR
1080
                  (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
1081
    -----------------------------------------------------------------------
1082
1083
1084
1085
1086
1087
1088
1089
1090
    data_cons = tyConDataCons tycon
    shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc data_cons)

    pats_etc data_con
      | nullary_con =  -- skip the showParen junk...
         ASSERT(null bs_needed)
         ([nlWildPat, con_pat], mk_showString_app op_con_str)
      | otherwise   =
         ([a_Pat, con_pat],
1091
1092
          showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
                         (nlHsPar (nested_compose_Expr show_thingies)))
1093
        where
1094
1095
1096
1097
1098
1099
             data_con_RDR  = getRdrName data_con
             con_arity     = dataConSourceArity data_con
             bs_needed     = take con_arity bs_RDRs
             arg_tys       = dataConOrigArgTys data_con         -- Correspond 1-1 with bs_needed
             con_pat       = nlConVarPat data_con_RDR bs_needed
             nullary_con   = con_arity == 0
1100
             labels        = dataConFieldLabels data_con
1101
1102
             lab_fields    = length labels
             record_syntax = lab_fields > 0
sof's avatar
sof committed
1103

1104
1105
             dc_nm          = getName data_con
             dc_occ_nm      = getOccName data_con
1106
             con_str        = occNameString dc_occ_nm
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
             op_con_str     = wrapOpParens con_str
             backquote_str  = wrapOpBackquotes con_str

             show_thingies
                | is_infix      = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
                | record_syntax = mk_showString_app (op_con_str ++ " {") :
                                  show_record_args ++ [mk_showString_app "}"]
                | otherwise     = mk_showString_app (op_con_str ++ " ") : show_prefix_args

             show_label l = mk_showString_app (nm ++ " = ")
                        -- Note the spaces around the "=" sign.  If we
                        -- don't have them then we get Foo { x=-1 } and
                        -- the "=-" parses as a single lexeme.  Only the
                        -- space after the '=' is necessary, but it
                        -- seems tidier to have them both sides.
                 where
                   occ_nm   = getOccName l
                   nm       = wrapOpParens (occNameString occ_nm)

             show_args               = zipWith show_arg bs_needed arg_tys
             (show_arg1:show_arg2:_) = show_args
             show_prefix_args        = intersperse (nlHsVar showSpace_RDR) show_args

                -- Assumption for record syntax: no of fields == no of
                -- labelled fields (and in same order)
             show_record_args = concat $
                                intersperse [mk_showString_app ", "] $
                                [ [show_label lbl, arg]
                                | (lbl,arg) <- zipEqual "gen_Show_binds"
                                                        labels show_args ]

                -- Generates (showsPrec p x) for argument x, but it also boxes
                -- the argument first if necessary.  Note that this prints unboxed
                -- things without any '#' decorations; could change that if need be
             show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
                                                         box_if_necy "Show" tycon (nlHsVar b) arg_ty]

                -- Fixity stuff
             is_infix = dataConIsInfix data_con
1146
             con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1147
1148
             arg_prec | record_syntax = 0  -- Record fields don't need parens
                      | otherwise     = con_prec_plus_one
1149

1150
1151
wrapOpParens :: String -> String
wrapOpParens s | isSym s   = '(' : s ++ ")"
1152
               | otherwise = s
1153
1154
1155

wrapOpBackquotes :: String -> String
wrapOpBackquotes s | isSym s   = s
1156
                   | otherwise = '`' : s ++ "`"
1157
1158

isSym :: String -> Bool
Ian Lynagh's avatar
Ian Lynagh committed
1159
1160
isSym ""      = False
isSym (c : _) = startsVarSym c || startsConSym c
1161

Ian Lynagh's avatar
Ian Lynagh committed
1162
mk_showString_app :: String -> LHsExpr RdrName
1163
mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1164
1165
\end{code}

sof's avatar
sof committed
1166
\begin{code}
1167
getPrec :: Bool -> FixityEnv -> Name -> Integer
1168
getPrec is_infix get_fixity nm
1169
1170
  | not is_infix   = appPrecedence
  | otherwise      = getPrecedence get_fixity nm
1171

1172
appPrecedence :: Integer
1173
appPrecedence = fromIntegral maxPrecedence + 1
1174
  -- One more than the precedence of the most
1175