TcGenDeriv.hs 84.9 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
{-# LANGUAGE TypeFamilies #-}
18

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

Ryan Scott's avatar
Ryan Scott committed
22
23
24
25
26
27
28
29
30
        gen_Eq_binds,
        gen_Ord_binds,
        gen_Enum_binds,
        gen_Bounded_binds,
        gen_Ix_binds,
        gen_Show_binds,
        gen_Read_binds,
        gen_Data_binds,
        gen_Lift_binds,
31
        gen_Newtype_binds,
Ryan Scott's avatar
Ryan Scott committed
32
        mkCoerceClassMethEqn,
33
        genAuxBinds,
Ryan Scott's avatar
Ryan Scott committed
34
        ordOpTbl, boxConTbl, litConTbl,
35
        mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr
36
    ) where
37

38
#include "HsVersions.h"
39

40
41
import GhcPrelude

42
import TcRnMonad
43
import HsSyn
44
45
46
47
import RdrName
import BasicTypes
import DataCon
import Name
niteria's avatar
niteria committed
48
49
import Fingerprint
import Encoding
50

51
import DynFlags
52
import PrelInfo
53
54
import FamInst
import FamInstEnv
55
import PrelNames
Ryan Scott's avatar
Ryan Scott committed
56
57
import THNames
import Module ( moduleName, moduleNameString
58
              , moduleUnitId, unitIdString )
59
import MkId ( coerceId )
60
61
62
import PrimOp
import SrcLoc
import TyCon
63
import TcEnv
64
import TcType
65
import TcValidity ( checkValidTyFamEqn )
66
67
import TysPrim
import TysWiredIn
68
import Type
69
import Class
70
import VarSet
71
import VarEnv
72
import Util
73
import Var
74
import Outputable
75
import Lexeme
76
import FastString
77
import Pair
78
import Bag
79

80
import Data.List  ( partition, intersperse )
81

82
83
type BagDerivStuff = Bag DerivStuff

84
data AuxBindSpec
85
86
87
  = DerivCon2Tag TyCon  -- The con2Tag for given TyCon
  | DerivTag2Con TyCon  -- ...ditto tag2Con
  | DerivMaxTag  TyCon  -- ...and maxTag
88
  deriving( Eq )
89
90
91
  -- All these generate ZERO-BASED tag operations
  -- I.e first constructor has tag 0

92
93
94
data DerivStuff     -- Please add this auxiliary stuff
  = DerivAuxBind AuxBindSpec

95
  -- Generics and DeriveAnyClass
Simon Peyton Jones's avatar
Simon Peyton Jones committed
96
  | DerivFamInst FamInst               -- New type family instances
97

98
  -- New top-level auxiliary bindings
99
  | DerivHsBind (LHsBind GhcPs, LSig GhcPs) -- Also used for SYB
100

101

Austin Seipp's avatar
Austin Seipp committed
102
103
104
{-
************************************************************************
*                                                                      *
105
                Eq instances
Austin Seipp's avatar
Austin Seipp committed
106
107
*                                                                      *
************************************************************************
108

109
110
111
112
113
114
115
116
117
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
118
119
  Usual Thing, e.g.,:

120
121
122
123
124
125
126
    (==) (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
127
128
  for that particular test.

Peter Trommler's avatar
Peter Trommler committed
129
* If there are a lot of (more than ten) nullary constructors, we emit a
130
  catch-all clause of the form:
131

132
133
134
135
      (==) a b  = case (con2tag_Foo a) of { a# ->
                  case (con2tag_Foo b) of { b# ->
                  case (a# ==# b#)     of {
                    r -> r }}}
136

137
138
139
140
141
  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
142
143
  catch-all:

144
     (==) a b  = False
145

146
* For the @(/=)@ method, we normally just use the default method.
147
148
149
150
  If the type is an enumeration type, we could/may/should? generate
  special code that calls @con2tag_Foo@, much like for @(==)@ shown
  above.

151
152
153
154
155
156
157
158
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
159
-}
sof's avatar
sof committed
160

161
gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
Sylvain Henry's avatar
Sylvain Henry committed
162
163
164
gen_Eq_binds loc tycon = do
    dflags <- getDynFlags
    return (method_binds dflags, aux_binds)
165
  where
166
167
168
169
170
171
172
173
174
    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)
175

176
    no_tag_match_cons = null tag_match_cons
177

Sylvain Henry's avatar
Sylvain Henry committed
178
    fall_through_eqn dflags
179
180
      | no_tag_match_cons   -- All constructors have arguments
      = case pat_match_cons of
181
          []  -> []   -- No constructors; no fall-though case
182
          [_] -> []   -- One constructor; no fall-though case
183
          _   ->      -- Two or more constructors; add fall-through of
184
185
                      --       (==) _ _ = False
                 [([nlWildPat, nlWildPat], false_Expr)]
186

187
      | otherwise -- One or more tag_match cons; add fall-through of
188
189
                  -- extract tags compare for equality
      = [([a_Pat, b_Pat],
Sylvain Henry's avatar
Sylvain Henry committed
190
         untag_Expr dflags tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
191
                    (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
192

193
194
    aux_binds | no_tag_match_cons = emptyBag
              | otherwise         = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
195

196
197
    method_binds dflags = unitBag (eq_bind dflags)
    eq_bind dflags = mkFunBindSE 2 loc eq_RDR (map pats_etc pat_match_cons
Sylvain Henry's avatar
Sylvain Henry committed
198
                                            ++ fall_through_eqn dflags)
199

200
201
202
    ------------------------------------------------------------------
    pats_etc data_con
      = let
Alan Zimmerman's avatar
Alan Zimmerman committed
203
204
            con1_pat = nlParPat $ nlConVarPat data_con_RDR as_needed
            con2_pat = nlParPat $ nlConVarPat data_con_RDR bs_needed
205
206
207
208
209
210
211
212

            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)
213
      where
214
215
216
217
218
        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))
219

Austin Seipp's avatar
Austin Seipp committed
220
221
222
{-
************************************************************************
*                                                                      *
223
        Ord instances
Austin Seipp's avatar
Austin Seipp committed
224
225
*                                                                      *
************************************************************************
226

227
228
Note [Generating Ord instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
229
Suppose constructors are K1..Kn, and some are nullary.
230
231
232
The general form we generate is:

* Do case on first argument
233
        case a of
234
235
236
237
238
239
240
          K1 ... -> rhs_1
          K2 ... -> rhs_2
          ...
          Kn ... -> rhs_n
          _ -> nullary_rhs

* To make rhs_i
241
242
     If i = 1, 2, n-1, n, generate a single case.
        rhs_2    case b of
243
244
245
246
247
248
249
250
                   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
251
                 else case b of
252
253
254
                         K3 ... -> ...eq_rhs(K3)....
                         _      -> LT

255
* To make eq_rhs(K), which knows that
256
257
258
259
260
261
    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
262
263
     case con2tag a of a# ->
     case con2tag b of ->
264
265
266
267
268
269
270
     a# `compare` b#

Several special cases:

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

* Be careful about unlifted comparisons.  When comparing unboxed
271
  values we can't call the overloaded functions.
272
273
  See function unliftedOrdOp

274
Note [Game plan for deriving Ord]
275
276
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's a bad idea to define only 'compare', and build the other binary
Gabor Greif's avatar
Gabor Greif committed
277
comparisons on top of it; see Trac #2130, #4019.  Reason: we don't
278
279
280
281
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
282
                            False -> case ==# x y of
283
284
                                       True  -> False
                                       False -> True
285

286
287
288
289
290
291
292
This being said, we can get away with generating full code only for
'compare' and '<' thus saving us generation of other three operators.
Other operators can be cheaply expressed through '<':
a <= b = not $ b < a
a > b = b < a
a >= b = not $ a < b

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

Austin Seipp's avatar
Austin Seipp committed
296
-}
297

298
299
300
301
302
303
304
305
306
307
308
309
310
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

------------
311
ltResult :: OrdOp -> LHsExpr GhcPs
312
313
314
315
316
317
318
319
-- 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

------------
320
eqResult :: OrdOp -> LHsExpr GhcPs
321
322
323
324
325
326
327
328
-- 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

------------
329
gtResult :: OrdOp -> LHsExpr GhcPs
330
331
332
333
334
335
336
337
-- 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

------------
338
gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
Sylvain Henry's avatar
Sylvain Henry committed
339
340
341
gen_Ord_binds loc tycon = do
    dflags <- getDynFlags
    return $ if null tycon_data_cons -- No data-cons => invoke bale-out case
342
      then ( unitBag $ mkFunBindSE 2 loc compare_RDR []
Sylvain Henry's avatar
Sylvain Henry committed
343
344
345
           , emptyBag)
      else ( unitBag (mkOrdOp dflags OrdCompare) `unionBags` other_ops dflags
           , aux_binds)
346
  where
347
    aux_binds | single_con_type = emptyBag
348
              | otherwise       = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
349

350
        -- Note [Game plan for deriving Ord]
Sylvain Henry's avatar
Sylvain Henry committed
351
352
353
354
355
356
    other_ops dflags
      | (last_tag - first_tag) <= 2     -- 1-3 constructors
        || null non_nullary_cons        -- Or it's an enumeration
      = listToBag [mkOrdOp dflags OrdLT, lE, gT, gE]
      | otherwise
      = emptyBag
357

358
359
360
361
362
363
364
365
    negate_expr = nlHsApp (nlHsVar not_RDR)
    lE = mk_easy_FunBind loc le_RDR [a_Pat, b_Pat] $
        negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr)
    gT = mk_easy_FunBind loc gt_RDR [a_Pat, b_Pat] $
        nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr
    gE = mk_easy_FunBind loc ge_RDR [a_Pat, b_Pat] $
        negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) a_Expr) b_Expr)

366
367
368
    get_tag con = dataConTag con - fIRST_TAG
        -- We want *zero-based* tags, because that's what
        -- con2Tag returns (generated by untag_Expr)!
369

370
371
372
373
    tycon_data_cons = tyConDataCons tycon
    single_con_type = isSingleton tycon_data_cons
    (first_con : _) = tycon_data_cons
    (last_con : _)  = reverse tycon_data_cons
374
375
    first_tag       = get_tag first_con
    last_tag        = get_tag last_con
376

377
    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
378

379

380
    mkOrdOp :: DynFlags -> OrdOp -> LHsBind GhcPs
381
    -- Returns a binding   op a b = ... compares a and b according to op ....
Sylvain Henry's avatar
Sylvain Henry committed
382
383
    mkOrdOp dflags op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat]
                                        (mkOrdOpRhs dflags op)
384

385
    mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr GhcPs
Sylvain Henry's avatar
Sylvain Henry committed
386
    mkOrdOpRhs dflags op       -- RHS for comparing 'a' and 'b' according to op
387
      | nullary_cons `lengthAtMost` 2 -- Two nullary or fewer, so use cases
388
      = nlHsCase (nlHsVar a_RDR) $
Sylvain Henry's avatar
Sylvain Henry committed
389
        map (mkOrdOpAlt dflags op) tycon_data_cons
390
        -- i.e.  case a of { C1 x y -> case b of C1 x y -> ....compare x,y...
391
        --                   C2 x   -> case b of C2 x -> ....comopare x.... }
392

393
      | null non_nullary_cons    -- All nullary, so go straight to comparing tags
Sylvain Henry's avatar
Sylvain Henry committed
394
      = mkTagCmp dflags op
395

396
      | otherwise                -- Mixed nullary and non-nullary
397
      = nlHsCase (nlHsVar a_RDR) $
Sylvain Henry's avatar
Sylvain Henry committed
398
399
        (map (mkOrdOpAlt dflags op) non_nullary_cons
         ++ [mkHsCaseAlt nlWildPat (mkTagCmp dflags op)])
400

401

Sylvain Henry's avatar
Sylvain Henry committed
402
    mkOrdOpAlt :: DynFlags -> OrdOp -> DataCon
403
                  -> LMatch GhcPs (LHsExpr GhcPs)
404
    -- Make the alternative  (Ki a1 a2 .. av ->
Sylvain Henry's avatar
Sylvain Henry committed
405
    mkOrdOpAlt dflags op data_con
406
      = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed)
Sylvain Henry's avatar
Sylvain Henry committed
407
                    (mkInnerRhs dflags op data_con)
408
409
410
411
      where
        as_needed    = take (dataConSourceArity data_con) as_RDRs
        data_con_RDR = getRdrName data_con

Sylvain Henry's avatar
Sylvain Henry committed
412
    mkInnerRhs dflags op data_con
413
414
415
416
417
      | single_con_type
      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ]

      | tag == first_tag
      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
418
                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
419
      | tag == last_tag
420
      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
421
                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
422

423
      | tag == first_tag + 1
424
425
      = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat first_con)
                                             (gtResult op)
426
                                 , mkInnerEqAlt op data_con
427
                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
428
      | tag == last_tag - 1
429
430
      = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat last_con)
                                             (ltResult op)
431
                                 , mkInnerEqAlt op data_con
432
                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
433

434
      | tag > last_tag `div` 2  -- lower range is larger
Sylvain Henry's avatar
Sylvain Henry committed
435
      = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $
436
        nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
437
               (gtResult op) $  -- Definitely GT
438
        nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
439
                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
440
441

      | otherwise               -- upper range is larger
Sylvain Henry's avatar
Sylvain Henry committed
442
      = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $
443
        nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
444
               (ltResult op) $  -- Definitely LT
445
        nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
446
                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
447
      where
448
        tag     = get_tag data_con
Alan Zimmerman's avatar
Alan Zimmerman committed
449
        tag_lit = noLoc (HsLit (HsIntPrim NoSourceText (toInteger tag)))
450

451
    mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
452
453
454
    -- 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
455
      = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $
456
        mkCompareFields tycon op (dataConOrigArgTys data_con)
457
458
459
460
      where
        data_con_RDR = getRdrName data_con
        bs_needed    = take (dataConSourceArity data_con) bs_RDRs

461
    mkTagCmp :: DynFlags -> OrdOp -> LHsExpr GhcPs
462
    -- Both constructors known to be nullary
463
    -- generates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#
Sylvain Henry's avatar
Sylvain Henry committed
464
465
466
    mkTagCmp dflags op =
      untag_Expr dflags tycon[(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $
        unliftedOrdOp tycon intPrimTy op ah_RDR bh_RDR
467

468
mkCompareFields :: TyCon -> OrdOp -> [Type] -> LHsExpr GhcPs
469
470
471
472
473
474
475
-- 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:_)
476
      | isUnliftedType ty     = unliftedOrdOp tycon ty op a b
477
      | otherwise             = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)
478
479
    go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
                                  (ltResult op)
480
                                  (go tys as bs)
481
                                  (gtResult op)
482
483
484
485
    go _ _ _ = panic "mkCompareFields"

    -- (mk_compare ty a b) generates
    --    (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })
486
    -- but with suitable special cases for
487
    mk_compare ty a b lt eq gt
488
      | isUnliftedType ty
489
      = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
490
      | otherwise
491
      = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr))
492
493
494
          [mkHsCaseAlt (nlNullaryConPat ltTag_RDR) lt,
           mkHsCaseAlt (nlNullaryConPat eqTag_RDR) eq,
           mkHsCaseAlt (nlNullaryConPat gtTag_RDR) gt]
495
496
497
498
499
      where
        a_expr = nlHsVar a
        b_expr = nlHsVar b
        (lt_op, _, eq_op, _, _) = primOrdOps "Ord" tycon ty

500
unliftedOrdOp :: TyCon -> Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs
501
502
unliftedOrdOp tycon ty op a b
  = case op of
503
       OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
504
505
506
507
508
509
510
                                     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
511
   wrap prim_op = genPrimOpApp a_expr prim_op b_expr
512
513
514
   a_expr = nlHsVar a
   b_expr = nlHsVar b

515
unliftedCompare :: RdrName -> RdrName
516
517
518
519
                -> LHsExpr GhcPs -> LHsExpr GhcPs   -- What to cmpare
                -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
                                                    -- Three results
                -> LHsExpr GhcPs
520
521
-- 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
522
  = nlHsIf (ascribeBool $ genPrimOpApp a_expr lt_op b_expr) lt $
Gabor Greif's avatar
typos    
Gabor Greif committed
523
                        -- Test (<) first, not (==), because the latter
524
525
                        -- is true less often, so putting it first would
                        -- mean more tests (dynamically)
526
527
        nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt
  where
528
    ascribeBool e = nlExprWithTySig e boolTy
529

530
nlConWildPat :: DataCon -> LPat GhcPs
531
532
-- The pattern (K {})
nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con))
533
                                   (RecCon (HsRecFields { rec_flds = []
534
                                                        , rec_dotdot = Nothing })))
535

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

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

556
557
    toEnum i = tag2con_Foo i

558
559
560
561
562
    enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]

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

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

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

579
gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
Sylvain Henry's avatar
Sylvain Henry committed
580
581
582
gen_Enum_binds loc tycon = do
    dflags <- getDynFlags
    return (method_binds dflags, aux_binds)
583
  where
Sylvain Henry's avatar
Sylvain Henry committed
584
585
586
587
588
589
590
591
    method_binds dflags = listToBag
      [ succ_enum      dflags
      , pred_enum      dflags
      , to_enum        dflags
      , enum_from      dflags
      , enum_from_then dflags
      , from_enum      dflags
      ]
592
593
    aux_binds = listToBag $ map DerivAuxBind
                  [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
594

595
    occ_nm = getOccString tycon
sof's avatar
sof committed
596

Sylvain Henry's avatar
Sylvain Henry committed
597
    succ_enum dflags
598
      = mk_easy_FunBind loc succ_RDR [a_Pat] $
Sylvain Henry's avatar
Sylvain Henry committed
599
600
        untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
        nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR dflags tycon),
601
602
                               nlHsVarApps intDataCon_RDR [ah_RDR]])
             (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
Sylvain Henry's avatar
Sylvain Henry committed
603
             (nlHsApp (nlHsVar (tag2con_RDR dflags tycon))
604
605
606
                    (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
                                        nlHsIntLit 1]))

Sylvain Henry's avatar
Sylvain Henry committed
607
    pred_enum dflags
608
      = mk_easy_FunBind loc pred_RDR [a_Pat] $
Sylvain Henry's avatar
Sylvain Henry committed
609
        untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
610
611
612
        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")
Sylvain Henry's avatar
Sylvain Henry committed
613
             (nlHsApp (nlHsVar (tag2con_RDR dflags tycon))
614
                      (nlHsApps plus_RDR
615
616
                            [ nlHsVarApps intDataCon_RDR [ah_RDR]
                            , nlHsLit (HsInt def (mkIntegralLit (-1 :: Int)))]))
617

Sylvain Henry's avatar
Sylvain Henry committed
618
    to_enum dflags
619
      = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
620
621
        nlHsIf (nlHsApps and_RDR
                [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
Sylvain Henry's avatar
Sylvain Henry committed
622
623
624
625
                 nlHsApps le_RDR [ nlHsVar a_RDR
                                 , nlHsVar (maxtag_RDR dflags tycon)]])
             (nlHsVarApps (tag2con_RDR dflags tycon) [a_RDR])
             (illegal_toEnum_tag occ_nm (maxtag_RDR dflags tycon))
626

Sylvain Henry's avatar
Sylvain Henry committed
627
    enum_from dflags
628
      = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
Sylvain Henry's avatar
Sylvain Henry committed
629
          untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
630
          nlHsApps map_RDR
Sylvain Henry's avatar
Sylvain Henry committed
631
                [nlHsVar (tag2con_RDR dflags tycon),
632
633
                 nlHsPar (enum_from_to_Expr
                            (nlHsVarApps intDataCon_RDR [ah_RDR])
Sylvain Henry's avatar
Sylvain Henry committed
634
                            (nlHsVar (maxtag_RDR dflags tycon)))]
635

Sylvain Henry's avatar
Sylvain Henry committed
636
    enum_from_then dflags
637
      = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
Sylvain Henry's avatar
Sylvain Henry committed
638
639
          untag_Expr dflags tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
          nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $
640
641
642
643
644
645
            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)
Sylvain Henry's avatar
Sylvain Henry committed
646
                           (nlHsVar (maxtag_RDR dflags tycon))
647
                           ))
648

Sylvain Henry's avatar
Sylvain Henry committed
649
    from_enum dflags
650
      = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
Sylvain Henry's avatar
Sylvain Henry committed
651
          untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
652
          (nlHsVarApps intDataCon_RDR [ah_RDR])
653

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

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

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

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

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

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

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

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

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

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

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

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
747
-}
748

749
gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
750

Sylvain Henry's avatar
Sylvain Henry committed
751
752
753
754
gen_Ix_binds loc tycon = do
    dflags <- getDynFlags
    return $ if isEnumerationTyCon tycon
      then (enum_ixes dflags, listToBag $ map DerivAuxBind
755
                   [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
Sylvain Henry's avatar
Sylvain Henry committed
756
      else (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))
757
758
  where
    --------------------------------------------------------------
Sylvain Henry's avatar
Sylvain Henry committed
759
760
761
762
763
    enum_ixes dflags = listToBag
      [ enum_range   dflags
      , enum_index   dflags
      , enum_inRange dflags
      ]
764

Sylvain Henry's avatar
Sylvain Henry committed
765
    enum_range dflags
766
      = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
Sylvain Henry's avatar
Sylvain Henry committed
767
768
769
          untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
          untag_Expr dflags tycon [(b_RDR, bh_RDR)] $
          nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $
770
771
772
              nlHsPar (enum_from_to_Expr
                        (nlHsVarApps intDataCon_RDR [ah_RDR])
                        (nlHsVarApps intDataCon_RDR [bh_RDR]))
773

Sylvain Henry's avatar
Sylvain Henry committed
774
    enum_index dflags
775
776
777
778
      = mk_easy_FunBind loc unsafeIndex_RDR
                [noLoc (AsPat (noLoc c_RDR)
                           (nlTuplePat [a_Pat, nlWildPat] Boxed)),
                                d_Pat] (
Sylvain Henry's avatar
Sylvain Henry committed
779
780
           untag_Expr dflags tycon [(a_RDR, ah_RDR)] (
           untag_Expr dflags tycon [(d_RDR, dh_RDR)] (
781
782
783
784
785
           let
                rhs = nlHsVarApps intDataCon_RDR [c_RDR]
           in
           nlHsCase
             (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
786
             [mkHsCaseAlt (nlVarPat c_RDR) rhs]
787
788
           ))
        )
789

790
    -- This produces something like `(ch >= ah) && (ch <= bh)`
Sylvain Henry's avatar
Sylvain Henry committed
791
    enum_inRange dflags
792
      = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
Sylvain Henry's avatar
Sylvain Henry committed
793
794
795
          untag_Expr dflags tycon [(a_RDR, ah_RDR)] (
          untag_Expr dflags tycon [(b_RDR, bh_RDR)] (
          untag_Expr dflags tycon [(c_RDR, ch_RDR)] (
796
797
798
799
800
801
802
          -- This used to use `if`, which interacts badly with RebindableSyntax.
          -- See #11396.
          nlHsApps and_RDR
              [ genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)
              , genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR)
              ]
          )))
803
804

    --------------------------------------------------------------
805
    single_con_ixes
dreixel's avatar
dreixel committed
806
      = listToBag [single_con_range, single_con_index, single_con_inRange]
807
808

    data_con
809
810
811
      = case tyConSingleDataCon_maybe tycon of -- just checking...
          Nothing -> panic "get_Ix_binds"
          Just dc -> dc
812

813
    con_arity    = dataConSourceArity data_con
814
    data_con_RDR = getRdrName data_con
815

816
817
818
    as_needed = take con_arity as_RDRs
    bs_needed = take con_arity bs_RDRs
    cs_needed = take con_arity cs_RDRs
819

820
821
    con_pat  xs  = nlConVarPat data_con_RDR xs
    con_expr     = nlHsVarApps data_con_RDR cs_needed
sof's avatar
sof committed
822

823
824
    --------------------------------------------------------------
    single_con_range
825
826
827
      = mk_easy_FunBind loc range_RDR
          [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
        noLoc (mkHsComp ListComp stmts con_expr)
828
      where
829
        stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
830

831
832
833
        mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
                                 (nlHsApp (nlHsVar range_RDR)
                                          (mkLHsVarTuple [a,b]))
834
835
836

    ----------------
    single_con_index
837
838
839
      = mk_easy_FunBind loc unsafeIndex_RDR
                [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
                 con_pat cs_needed]
840
841
842
843
        -- 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.
844
                (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
845
      where
846
847
848
849
850
851
852
853
854
855
856
857
858
859
        -- 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]
860
861
862

    ------------------
    single_con_inRange
863
864
865
      = mk_easy_FunBind loc inRange_RDR
                [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
                 con_pat cs_needed] $
866
867
868
869
870
871
          if con_arity == 0
             -- If the product type has no fields, inRange is trivially true
             -- (see Trac #12853).
             then true_Expr
             else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range
                    as_needed bs_needed cs_needed)
872
      where
873
        in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
874

Austin Seipp's avatar
Austin Seipp committed
875
876
877
{-
************************************************************************
*                                                                      *
878
        Read instances
Austin Seipp's avatar
Austin Seipp committed
879
880
*                                                                      *
************************************************************************
881

882
883
884
885
Example

  infix 4 %%
  data T = Int %% Int
886
887
         | T1 { f1 :: Int }
         | T2 T
888
889
890

instance Read T where
  readPrec =
891
    parens
892
    ( prec 4 (
893
894
895
        do x <- ReadP.step Read.readPrec
           expectP (Symbol "%%")
           y <- ReadP.step Read.readPrec
896
897
           return (x %% y))
      +++
898
      prec (appPrec+1) (
899
900
        -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
        -- Record construction binds even more tightly than application
901
902
903
904
        do expectP (Ident "T1")
           expectP (Punc '{')
           expectP (Ident "f1")
           expectP (Punc '=')
905
           x          <- ReadP.reset Read.readPrec
906
           expectP (Punc '}')
907
           return (T1 { f1 = x }))
908
909
      +++
      prec appPrec (
910
911
        do expectP (Ident "T2")
           x <- ReadP.step Read.readPrec
912
913
914
915
916
917
918
           return (T2 x))
    )

  readListPrec = readListPrecDefault
  readList     = readListDefault


919
920
Note [Use expectP]
~~~~~~~~~~~~~~~~~~
921
Note that we use
922
923
924
925
926
927
928
   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.
929
930
931
932
933
934
935
936

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 []
937
So we do NOT want
938
939
940
941
942
943
944
   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.
945
These instances are also useful for Read (Either Int Emp), where
946
we want to be able to parse (Left 3) just fine.
Austin Seipp's avatar
Austin Seipp committed
947
-}
948

949
950
gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon
               -> (LHsBinds GhcPs, BagDerivStuff)
951

952
gen_Read_binds get_fixity loc tycon
dreixel's avatar
dreixel committed
953
  = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)