TcGenDeriv.hs 101 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1
{-
2
    %
Austin Seipp's avatar
Austin Seipp committed
3
4
5
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

6
7

TcGenDeriv: Generating derived instance declarations
8
9
10
11
12

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.
Austin Seipp's avatar
Austin Seipp committed
13
-}
14

15
{-# LANGUAGE CPP, ScopedTypeVariables #-}
16
{-# LANGUAGE FlexibleContexts #-}
17

18
module TcGenDeriv (
19
20
        BagDerivStuff, DerivStuff(..),

21
        hasBuiltinDeriving,
22
23
        FFoldType(..), functorLikeTraverse,
        deepSubtypesContaining, foldDataConArgs,
24
        mkCoerceClassMethEqn,
25
        gen_Newtype_binds,
26
        genAuxBinds,
Ryan Scott's avatar
Ryan Scott committed
27
        ordOpTbl, boxConTbl, litConTbl,
Gergő Érdi's avatar
Gergő Érdi committed
28
        mkRdrFunBind
29
    ) where
30

31
#include "HsVersions.h"
32

33
import HsSyn
34
35
36
37
import RdrName
import BasicTypes
import DataCon
import Name
niteria's avatar
niteria committed
38
39
import Fingerprint
import Encoding
40

41
import DynFlags
42
import PrelInfo
43
import FamInstEnv( FamInst )
44
import PrelNames
Ryan Scott's avatar
Ryan Scott committed
45
46
import THNames
import Module ( moduleName, moduleNameString
47
              , moduleUnitId, unitIdString )
48
import MkId ( coerceId )
49
50
51
52
53
54
import PrimOp
import SrcLoc
import TyCon
import TcType
import TysPrim
import TysWiredIn
55
import Type
56
import Class
57
import TyCoRep
58
import VarSet
59
import VarEnv
60
import State
61
import Util
62
import Var
63
import Outputable
64
import Lexeme
65
import FastString
66
import Pair
67
import Bag
68
import TcEnv (InstInfo)
69
import StaticFlags( opt_PprStyle_Debug )
70

71
72
import ListSetOps ( assocMaybe )
import Data.List  ( partition, intersperse )
73

74
75
type BagDerivStuff = Bag DerivStuff

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

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

87
  -- Generics
Simon Peyton Jones's avatar
Simon Peyton Jones committed
88
  | DerivFamInst FamInst               -- New type family instances
89

90
  -- New top-level auxiliary bindings
91
  | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB
dreixel's avatar
dreixel committed
92
  | DerivInst (InstInfo RdrName)                -- New, auxiliary instances
93

Austin Seipp's avatar
Austin Seipp committed
94
95
96
{-
************************************************************************
*                                                                      *
97
                Class deriving diagnostics
Austin Seipp's avatar
Austin Seipp committed
98
99
*                                                                      *
************************************************************************
100

101
102
103
104
105
106
107
108
Only certain blessed classes can be used in a deriving clause. These classes
are listed below in the definition of hasBuiltinDeriving (with the exception
of Generic and Generic1, which are handled separately in TcGenGenerics).

A class might be able to be used in a deriving clause if it -XDeriveAnyClass
is willing to support it. The canDeriveAnyClass function checks if this is
the case.
-}
109

110
111
112
113
114
115
116
hasBuiltinDeriving :: DynFlags
                   -> (Name -> Fixity)
                   -> Class
                   -> Maybe (SrcSpan
                             -> TyCon
                             -> (LHsBinds RdrName, BagDerivStuff))
hasBuiltinDeriving dflags fix_env clas = assocMaybe gen_list (getUnique clas)
117
118
119
120
121
122
123
124
125
126
127
128
  where
    gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))]
    gen_list = [ (eqClassKey,          gen_Eq_binds)
               , (ordClassKey,         gen_Ord_binds)
               , (enumClassKey,        gen_Enum_binds)
               , (boundedClassKey,     gen_Bounded_binds)
               , (ixClassKey,          gen_Ix_binds)
               , (showClassKey,        gen_Show_binds fix_env)
               , (readClassKey,        gen_Read_binds fix_env)
               , (dataClassKey,        gen_Data_binds dflags)
               , (functorClassKey,     gen_Functor_binds)
               , (foldableClassKey,    gen_Foldable_binds)
Ryan Scott's avatar
Ryan Scott committed
129
130
               , (traversableClassKey, gen_Traversable_binds)
               , (liftClassKey,        gen_Lift_binds) ]
131

Austin Seipp's avatar
Austin Seipp committed
132
133
134
{-
************************************************************************
*                                                                      *
135
                Eq instances
Austin Seipp's avatar
Austin Seipp committed
136
137
*                                                                      *
************************************************************************
138

139
140
141
142
143
144
145
146
147
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
148
149
  Usual Thing, e.g.,:

150
151
152
153
154
155
156
    (==) (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
157
158
  for that particular test.

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

162
163
164
165
      (==) a b  = case (con2tag_Foo a) of { a# ->
                  case (con2tag_Foo b) of { b# ->
                  case (a# ==# b#)     of {
                    r -> r }}}
166

167
168
169
170
171
  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
172
173
  catch-all:

174
     (==) a b  = False
175

176
* For the @(/=)@ method, we normally just use the default method.
177
178
179
180
  If the type is an enumeration type, we could/may/should? generate
  special code that calls @con2tag_Foo@, much like for @(==)@ shown
  above.

181
182
183
184
185
186
187
188
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.
Austin Seipp's avatar
Austin Seipp committed
189
-}
sof's avatar
sof committed
190

dreixel's avatar
dreixel committed
191
gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
192
gen_Eq_binds loc tycon
dreixel's avatar
dreixel committed
193
  = (method_binds, aux_binds)
194
  where
195
196
197
198
199
200
201
202
203
    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)
204

205
    no_tag_match_cons = null tag_match_cons
206

207
    fall_through_eqn
208
209
      | no_tag_match_cons   -- All constructors have arguments
      = case pat_match_cons of
210
          []  -> []   -- No constructors; no fall-though case
211
          [_] -> []   -- One constructor; no fall-though case
212
          _   ->      -- Two or more constructors; add fall-through of
213
214
                      --       (==) _ _ = False
                 [([nlWildPat, nlWildPat], false_Expr)]
215

216
      | otherwise -- One or more tag_match cons; add fall-through of
217
218
                  -- extract tags compare for equality
      = [([a_Pat, b_Pat],
219
         untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
220
                    (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
221

222
223
    aux_binds | no_tag_match_cons = emptyBag
              | otherwise         = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
224

dreixel's avatar
dreixel committed
225
    method_binds = listToBag [eq_bind, ne_bind]
226
    eq_bind = mk_FunBind loc eq_RDR (map pats_etc pat_match_cons ++ fall_through_eqn)
227
    ne_bind = mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
228
                        nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
229

230
231
232
    ------------------------------------------------------------------
    pats_etc data_con
      = let
233
234
235
236
237
238
239
240
241
242
            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)
243
      where
244
245
246
247
248
        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))
249

Austin Seipp's avatar
Austin Seipp committed
250
251
252
{-
************************************************************************
*                                                                      *
253
        Ord instances
Austin Seipp's avatar
Austin Seipp committed
254
255
*                                                                      *
************************************************************************
256

257
258
Note [Generating Ord instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
259
Suppose constructors are K1..Kn, and some are nullary.
260
261
262
The general form we generate is:

* Do case on first argument
263
        case a of
264
265
266
267
268
269
270
          K1 ... -> rhs_1
          K2 ... -> rhs_2
          ...
          Kn ... -> rhs_n
          _ -> nullary_rhs

* To make rhs_i
271
272
     If i = 1, 2, n-1, n, generate a single case.
        rhs_2    case b of
273
274
275
276
277
278
279
280
                   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
281
                 else case b of
282
283
284
                         K3 ... -> ...eq_rhs(K3)....
                         _      -> LT

285
* To make eq_rhs(K), which knows that
286
287
288
289
290
291
    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
292
293
     case con2tag a of a# ->
     case con2tag b of ->
294
295
296
297
298
299
300
     a# `compare` b#

Several special cases:

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

* Be careful about unlifted comparisons.  When comparing unboxed
301
  values we can't call the overloaded functions.
302
303
304
305
306
  See function unliftedOrdOp

Note [Do not rely on compare]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's a bad idea to define only 'compare', and build the other binary
Gabor Greif's avatar
Gabor Greif committed
307
comparisons on top of it; see Trac #2130, #4019.  Reason: we don't
308
309
310
311
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
312
                            False -> case ==# x y of
313
314
                                       True  -> False
                                       False -> True
315

316
So for sufficiently small types (few constructors, or all nullary)
317
we generate all methods; for large ones we just use 'compare'.
Austin Seipp's avatar
Austin Seipp committed
318
-}
319

320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
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
360
gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
361
gen_Ord_binds loc tycon
362
  | null tycon_data_cons        -- No data-cons => invoke bale-out case
dreixel's avatar
dreixel committed
363
  = (unitBag $ mk_FunBind loc compare_RDR [], emptyBag)
364
  | otherwise
dreixel's avatar
dreixel committed
365
  = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
366
  where
367
    aux_binds | single_con_type = emptyBag
368
              | otherwise       = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
369

370
371
372
        -- 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
373
              = listToBag (map mkOrdOp [OrdLT,OrdLE,OrdGE,OrdGT])
374
              | otherwise
375
              = emptyBag
376

377
378
379
    get_tag con = dataConTag con - fIRST_TAG
        -- We want *zero-based* tags, because that's what
        -- con2Tag returns (generated by untag_Expr)!
380

381
382
383
384
    tycon_data_cons = tyConDataCons tycon
    single_con_type = isSingleton tycon_data_cons
    (first_con : _) = tycon_data_cons
    (last_con : _)  = reverse tycon_data_cons
385
386
    first_tag       = get_tag first_con
    last_tag        = get_tag last_con
387

388
    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
389

390

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

395
    mkOrdOpRhs :: OrdOp -> LHsExpr RdrName
396
    mkOrdOpRhs op       -- RHS for comparing 'a' and 'b' according to op
397
      | length nullary_cons <= 2  -- Two nullary or fewer, so use cases
398
      = nlHsCase (nlHsVar a_RDR) $
399
        map (mkOrdOpAlt op) tycon_data_cons
400
        -- i.e.  case a of { C1 x y -> case b of C1 x y -> ....compare x,y...
401
        --                   C2 x   -> case b of C2 x -> ....comopare x.... }
402

403
404
      | null non_nullary_cons    -- All nullary, so go straight to comparing tags
      = mkTagCmp op
405

406
      | otherwise                -- Mixed nullary and non-nullary
407
      = nlHsCase (nlHsVar a_RDR) $
408
        (map (mkOrdOpAlt op) non_nullary_cons
409
         ++ [mkSimpleHsAlt nlWildPat (mkTagCmp op)])
410

411

412
    mkOrdOpAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
413
    -- Make the alternative  (Ki a1 a2 .. av ->
414
415
416
417
418
419
420
421
422
423
424
425
426
    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) ]
427
      | tag == last_tag
428
429
      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
                                 , mkSimpleHsAlt nlWildPat (gtResult op) ]
430

431
432
433
434
435
436
437
438
439
      | 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) ]

440
      | tag > last_tag `div` 2  -- lower range is larger
441
      = untag_Expr tycon [(b_RDR, bh_RDR)] $
442
        nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
443
               (gtResult op) $  -- Definitely GT
444
445
        nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
                                 , mkSimpleHsAlt nlWildPat (ltResult op) ]
446
447

      | otherwise               -- upper range is larger
448
      = untag_Expr tycon [(b_RDR, bh_RDR)] $
449
        nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
450
               (ltResult op) $  -- Definitely LT
451
452
453
        nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
                                 , mkSimpleHsAlt nlWildPat (gtResult op) ]
      where
454
        tag     = get_tag data_con
455
        tag_lit = noLoc (HsLit (HsIntPrim "" (toInteger tag)))
456

457
    mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
458
459
460
461
    -- 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) $
462
        mkCompareFields tycon op (dataConOrigArgTys data_con)
463
464
465
466
      where
        data_con_RDR = getRdrName data_con
        bs_needed    = take (dataConSourceArity data_con) bs_RDRs

467
    mkTagCmp :: OrdOp -> LHsExpr RdrName
468
469
470
471
    -- 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
472

473
474
475
476
477
478
479
480
481
482
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)
483
484
    go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
                                  (ltResult op)
485
                                  (go tys as bs)
486
                                  (gtResult op)
487
488
489
490
    go _ _ _ = panic "mkCompareFields"

    -- (mk_compare ty a b) generates
    --    (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })
491
    -- but with suitable special cases for
492
493
494
    mk_compare ty a b lt eq gt
      | isUnLiftedType ty
      = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
495
      | otherwise
496
497
498
499
500
501
502
503
504
505
506
507
      = 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
508
       OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
509
510
511
512
513
514
515
                                     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
516
   wrap prim_op = genPrimOpApp a_expr prim_op b_expr
517
518
519
   a_expr = nlHsVar a
   b_expr = nlHsVar b

520
unliftedCompare :: RdrName -> RdrName
521
                -> LHsExpr RdrName -> LHsExpr RdrName   -- What to cmpare
522
523
524
525
                -> 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
526
  = nlHsIf (genPrimOpApp a_expr lt_op b_expr) lt $
Gabor Greif's avatar
typos    
Gabor Greif committed
527
                        -- Test (<) first, not (==), because the latter
528
529
                        -- is true less often, so putting it first would
                        -- mean more tests (dynamically)
530
        nlHsIf (genPrimOpApp a_expr eq_op b_expr) eq gt
531
532
533
534

nlConWildPat :: DataCon -> LPat RdrName
-- The pattern (K {})
nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con))
535
                                   (RecCon (HsRecFields { rec_flds = []
536
                                                        , rec_dotdot = Nothing })))
537

Austin Seipp's avatar
Austin Seipp committed
538
539
540
{-
************************************************************************
*                                                                      *
541
        Enum instances
Austin Seipp's avatar
Austin Seipp committed
542
543
*                                                                      *
************************************************************************
544
545
546
547
548
549
550
551
552
553
554

@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
555
556
557
    succ x   = toEnum (1 + fromEnum x)
    pred x   = toEnum (fromEnum x - 1)

558
559
    toEnum i = tag2con_Foo i

560
561
562
563
564
    enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]

    -- or, really...
    enumFrom a
      = case con2tag_Foo a of
565
          a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
566
567
568
569
570
571
572

   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# ->
573
574
575
        case con2tag_Foo b of { b# ->
        map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
        }}
576
577
578
\end{verbatim}

For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
Austin Seipp's avatar
Austin Seipp committed
579
-}
580

dreixel's avatar
dreixel committed
581
gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
582
gen_Enum_binds loc tycon
dreixel's avatar
dreixel committed
583
  = (method_binds, aux_binds)
584
  where
dreixel's avatar
dreixel committed
585
    method_binds = listToBag [
586
587
588
589
590
591
592
                        succ_enum,
                        pred_enum,
                        to_enum,
                        enum_from,
                        enum_from_then,
                        from_enum
                    ]
593
594
    aux_binds = listToBag $ map DerivAuxBind
                  [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
595

596
    occ_nm = getOccString tycon
sof's avatar
sof committed
597
598

    succ_enum
599
      = mk_easy_FunBind loc succ_RDR [a_Pat] $
600
601
602
603
604
605
606
607
        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
608
    pred_enum
609
      = mk_easy_FunBind loc pred_RDR [a_Pat] $
610
611
612
613
614
615
        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],
616
                                               nlHsLit (HsInt "-1" (-1))]))
617
618

    to_enum
619
      = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
620
621
        nlHsIf (nlHsApps and_RDR
                [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
622
623
                 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
             (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
624
             (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
625

626
    enum_from
627
      = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
628
629
630
631
632
633
          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)))]
634
635

    enum_from_then
636
      = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
637
638
639
640
641
642
643
644
645
646
          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))
                           ))
647
648

    from_enum
649
      = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
650
651
          untag_Expr tycon [(a_RDR, ah_RDR)] $
          (nlHsVarApps intDataCon_RDR [ah_RDR])
652

Austin Seipp's avatar
Austin Seipp committed
653
654
655
{-
************************************************************************
*                                                                      *
656
        Bounded instances
Austin Seipp's avatar
Austin Seipp committed
657
658
659
*                                                                      *
************************************************************************
-}
660

dreixel's avatar
dreixel committed
661
gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
662
gen_Bounded_binds loc tycon
663
  | isEnumerationTyCon tycon
dreixel's avatar
dreixel committed
664
  = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
665
666
  | otherwise
  = ASSERT(isSingleton data_cons)
dreixel's avatar
dreixel committed
667
    (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)
668
  where
669
    data_cons = tyConDataCons tycon
670
671

    ----- enum-flavored: ---------------------------
672
673
    min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
    max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
674

675
676
    data_con_1     = head data_cons
    data_con_N     = last data_cons
677
678
    data_con_1_RDR = getRdrName data_con_1
    data_con_N_RDR = getRdrName data_con_N
679
680

    ----- single-constructor-flavored: -------------
681
    arity          = dataConSourceArity data_con_1
682

683
    min_bound_1con = mkHsVarBind loc minBound_RDR $
684
                     nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
685
    max_bound_1con = mkHsVarBind loc maxBound_RDR $
686
                     nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
687

Austin Seipp's avatar
Austin Seipp committed
688
689
690
{-
************************************************************************
*                                                                      *
691
        Ix instances
Austin Seipp's avatar
Austin Seipp committed
692
693
*                                                                      *
************************************************************************
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710

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# ->
711
712
713
        case (con2tag_Foo b) of { b# ->
        map tag2con_Foo (enumFromTo (I# a#) (I# b#))
        }}
714

Gabor Greif's avatar
typos    
Gabor Greif committed
715
    -- Generate code for unsafeIndex, because using index leads
716
717
718
    -- to lots of redundant range tests
    unsafeIndex c@(a, b) d
      = case (con2tag_Foo d -# con2tag_Foo a) of
719
               r# -> I# r#
720
721
722

    inRange (a, b) c
      = let
723
724
725
            p_tag = con2tag_Foo c
        in
        p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
726
727
728
729

    -- or, really...
    inRange (a, b) c
      = case (con2tag_Foo a)   of { a_tag ->
730
731
732
733
734
735
736
        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
        }}}
737
\end{verbatim}
738
(modulo suitable case-ification to handle the unlifted tags)
739
740
741
742
743
744
745

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).
Austin Seipp's avatar
Austin Seipp committed
746
-}
747

dreixel's avatar
dreixel committed
748
gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
749

750
gen_Ix_binds loc tycon
751
  | isEnumerationTyCon tycon
752
753
754
  = ( enum_ixes
    , listToBag $ map DerivAuxBind
                   [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
755
  | otherwise
756
  = (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))
757
758
  where
    --------------------------------------------------------------
dreixel's avatar
dreixel committed
759
    enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
760
761

    enum_range
762
      = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
763
764
765
766
767
768
          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]))
769
770

    enum_index
771
772
773
774
775
776
777
778
779
780
781
782
783
784
      = 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]
           ))
        )
785
786

    enum_inRange
787
      = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
788
789
790
          untag_Expr tycon [(a_RDR, ah_RDR)] (
          untag_Expr tycon [(b_RDR, bh_RDR)] (
          untag_Expr tycon [(c_RDR, ch_RDR)] (
791
792
          nlHsIf (genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
             (genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
793
794
795
          ) {-else-} (
             false_Expr
          ))))
796
797

    --------------------------------------------------------------
798
    single_con_ixes
dreixel's avatar
dreixel committed
799
      = listToBag [single_con_range, single_con_index, single_con_inRange]
800
801

    data_con
802
803
804
      = case tyConSingleDataCon_maybe tycon of -- just checking...
          Nothing -> panic "get_Ix_binds"
          Just dc -> dc
805

806
    con_arity    = dataConSourceArity data_con
807
    data_con_RDR = getRdrName data_con
808

809
810
811
    as_needed = take con_arity as_RDRs
    bs_needed = take con_arity bs_RDRs
    cs_needed = take con_arity cs_RDRs
812

813
814
    con_pat  xs  = nlConVarPat data_con_RDR xs
    con_expr     = nlHsVarApps data_con_RDR cs_needed
sof's avatar
sof committed
815

816
817
    --------------------------------------------------------------
    single_con_range
818
819
820
      = mk_easy_FunBind loc range_RDR
          [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
        noLoc (mkHsComp ListComp stmts con_expr)
821
      where
822
        stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
823

824
825
826
        mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
                                 (nlHsApp (nlHsVar range_RDR)
                                          (mkLHsVarTuple [a,b]))
827
828
829

    ----------------
    single_con_index
830
831
832
      = mk_easy_FunBind loc unsafeIndex_RDR
                [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
                 con_pat cs_needed]
833
834
835
836
        -- 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.
837
                (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
838
      where
839
840
841
842
843
844
845
846
847
848
849
850
851
852
        -- 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]
853
854
855

    ------------------
    single_con_inRange
856
857
858
859
      = 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)
860
      where
861
        in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
862

Austin Seipp's avatar
Austin Seipp committed
863
864
865
{-
************************************************************************
*                                                                      *
866
        Read instances
Austin Seipp's avatar
Austin Seipp committed
867
868
*                                                                      *
************************************************************************
869

870
871
872
873
Example

  infix 4 %%
  data T = Int %% Int
874
875
         | T1 { f1 :: Int }
         | T2 T
876
877
878

instance Read T where
  readPrec =
879
    parens
880
    ( prec 4 (
881
882
883
        do x <- ReadP.step Read.readPrec
           expectP (Symbol "%%")
           y <- ReadP.step Read.readPrec
884
885
           return (x %% y))
      +++
886
      prec (appPrec+1) (
887
888
        -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
        -- Record construction binds even more tightly than application
889
890
891
892
        do expectP (Ident "T1")
           expectP (Punc '{')
           expectP (Ident "f1")
           expectP (Punc '=')
893
           x          <- ReadP.reset Read.readPrec
894
           expectP (Punc '}')
895
           return (T1 { f1 = x }))
896
897
      +++
      prec appPrec (
898
899
        do expectP (Ident "T2")
           x <- ReadP.step Read.readPrec
900
901
902
903
904
905
906
           return (T2 x))
    )

  readListPrec = readListPrecDefault
  readList     = readListDefault


907
908
Note [Use expectP]
~~~~~~~~~~~~~~~~~~
909
Note that we use
910
911
912
913
914
915
916
   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.
917
918
919
920
921
922
923
924

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 []
925
So we do NOT want
926
927
928
929
930
931
932
   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.
933
These instances are also useful for Read (Either Int Emp), where
934
we want to be able to parse (Left 3) just fine.
Austin Seipp's avatar
Austin Seipp committed
935
-}
936

937
gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
938

939
gen_Read_binds get_fixity loc tycon
dreixel's avatar
dreixel committed
940
  = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
941
  where
942
    -----------------------------------------------------------------------
943
944
    default_readlist
        = mkHsVarBind loc readList_RDR     (nlHsVar readListDefault_RDR)
945
946

    default_readlistprec
947
        = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
948
    -----------------------------------------------------------------------
949
950

    data_cons = tyConDataCons tycon
951
    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
952

953
    read_prec = mkHsVarBind loc readPrec_RDR
954
                              (nlHsApp (nlHsVar parens_RDR) read_cons)
955

956
    read_cons | null data_cons = nlHsVar pfail_RDR  -- See Note [Read for empty data types]
957
              | otherwise      = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
958
    read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
959
960

    read_nullary_cons
961
      = case nullary_cons of
962
963
964
965
            []    -> []
            [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])]
            _     -> [nlHsApp (nlHsVar choose_RDR)
                              (nlList (map mk_pair nullary_cons))]
966
        -- NB For operators the parens around (:=:) are matched by the
967
968
        -- enclosing "parens" call, so here we must match the naked
        -- data_con_str con
969

970
971
    match_con con | isSym con_str = [symbol_pat con_str]
                  | otherwise     = ident_h_pat  con_str
972
973
                  where
                    con_str = data_con_str con
974
975
        -- For nullary constructors we must match Ident s for normal constrs
        -- and   Symbol s   for operators
976

977
978
    mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),
                                  result_expr con []]
979

980
    read_non_nullary_con data_con
981
982
      | is_infix  = mk_parser infix_prec  infix_stmts  body
      | is_record = mk_parser record_prec record_stmts body
983
984
--              Using these two lines instead allows the derived
--              read for infix and record bindings to read the prefix form