TcGenDeriv.hs 94.3 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
22
        canDeriveAnyClass,
        genDerivedBinds,
23
24
        FFoldType(..), functorLikeTraverse,
        deepSubtypesContaining, foldDataConArgs,
25
        mkCoerceClassMethEqn,
26
        gen_Newtype_binds,
27
        genAuxBinds,
Gergő Érdi's avatar
Gergő Érdi committed
28
29
        ordOpTbl, boxConTbl,
        mkRdrFunBind
30
    ) where
31

32
#include "HsVersions.h"
33

34
import HsSyn
35
36
37
38
import RdrName
import BasicTypes
import DataCon
import Name
39

40
import DynFlags
41
import PrelInfo
42
import FamInstEnv( FamInst )
43
import MkCore ( eRROR_ID )
44
import PrelNames hiding (error_RDR)
45
import MkId ( coerceId )
46
47
48
49
50
51
import PrimOp
import SrcLoc
import TyCon
import TcType
import TysPrim
import TysWiredIn
52
import Type
53
import Class
54
55
import TypeRep
import VarSet
56
import VarEnv
57
import Module
58
import State
59
import Util
60
import Var
61
import MonadUtils
62
import Outputable
63
import Lexeme
64
import FastString
65
import Pair
66
import Bag
67
import Fingerprint
68
import TcEnv (InstInfo)
69
import StaticFlags( opt_PprStyle_Debug )
70

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

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
  | DerivTyCon TyCon                   -- New data types
Simon Peyton Jones's avatar
Simon Peyton Jones committed
90
  | DerivFamInst FamInst               -- New type family instances
91

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

Austin Seipp's avatar
Austin Seipp committed
96
97
98
{-
************************************************************************
*                                                                      *
99
                Top level function
Austin Seipp's avatar
Austin Seipp committed
100
101
102
*                                                                      *
************************************************************************
-}
103

104
genDerivedBinds :: DynFlags -> (Name -> Fixity) -> Class -> SrcSpan -> TyCon
Simon Peyton Jones's avatar
Simon Peyton Jones committed
105
106
107
                -> ( LHsBinds RdrName  -- The method bindings of the instance declaration
                   , BagDerivStuff)    -- Specifies extra top-level declarations needed
                                       -- to support the instance declaration
108
109
110
111
112
genDerivedBinds dflags fix_env clas loc tycon
  | Just gen_fn <- assocMaybe gen_list (getUnique clas)
  = gen_fn loc tycon

  | otherwise
113
114
115
116
117
118
  -- Deriving any class simply means giving an empty instance, so no
  -- bindings have to be generated.
  = ASSERT2( isNothing (canDeriveAnyClass dflags tycon clas)
           , ppr "genDerivStuff: bad derived class" <+> ppr clas )
    (emptyBag, emptyBag)

119
120
121
122
123
124
125
126
127
128
129
130
131
132
  where
    gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))]
    gen_list = [ (eqClassKey,          gen_Eq_binds)
               , (typeableClassKey,    gen_Typeable_binds dflags)
               , (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)
               , (traversableClassKey, gen_Traversable_binds) ]
133
134
135
136
137
138
139
140
141
142
143
144
145
146


-- Nothing: we can (try to) derive it via Generics
-- Just s:  we can't, reason s
canDeriveAnyClass :: DynFlags -> TyCon -> Class -> Maybe SDoc
canDeriveAnyClass dflags _tycon clas =
  let b `orElse` s = if b then Nothing else Just (ptext (sLit s))
      Just m  <> _ = Just m
      Nothing <> n = n
  -- We can derive a given class for a given tycon via Generics iff
  in  -- 1) The class is not a "standard" class (like Show, Functor, etc.)
        (not (getUnique clas `elem` standardClassKeys) `orElse` "")
      -- 2) Opt_DeriveAnyClass is on
     <> (xopt Opt_DeriveAnyClass dflags `orElse` "Try enabling DeriveAnyClass")
147

Austin Seipp's avatar
Austin Seipp committed
148
149
150
{-
************************************************************************
*                                                                      *
151
                Eq instances
Austin Seipp's avatar
Austin Seipp committed
152
153
*                                                                      *
************************************************************************
154

155
156
157
158
159
160
161
162
163
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
164
165
  Usual Thing, e.g.,:

166
167
168
169
170
171
172
    (==) (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
173
174
  for that particular test.

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

178
179
180
181
      (==) a b  = case (con2tag_Foo a) of { a# ->
                  case (con2tag_Foo b) of { b# ->
                  case (a# ==# b#)     of {
                    r -> r }}}
182

183
184
185
186
187
  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
188
189
  catch-all:

190
     (==) a b  = False
191

192
* For the @(/=)@ method, we normally just use the default method.
193
194
195
196
  If the type is an enumeration type, we could/may/should? generate
  special code that calls @con2tag_Foo@, much like for @(==)@ shown
  above.

197
198
199
200
201
202
203
204
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
205
-}
sof's avatar
sof committed
206

dreixel's avatar
dreixel committed
207
gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
208
gen_Eq_binds loc tycon
dreixel's avatar
dreixel committed
209
  = (method_binds, aux_binds)
210
  where
211
212
213
214
215
216
217
218
219
    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)
220

221
    no_tag_match_cons = null tag_match_cons
222

223
    fall_through_eqn
224
225
      | no_tag_match_cons   -- All constructors have arguments
      = case pat_match_cons of
226
          []  -> []   -- No constructors; no fall-though case
227
          [_] -> []   -- One constructor; no fall-though case
228
          _   ->      -- Two or more constructors; add fall-through of
229
230
                      --       (==) _ _ = False
                 [([nlWildPat, nlWildPat], false_Expr)]
231

232
      | otherwise -- One or more tag_match cons; add fall-through of
233
234
                  -- extract tags compare for equality
      = [([a_Pat, b_Pat],
235
         untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
236
                    (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
237

238
239
    aux_binds | no_tag_match_cons = emptyBag
              | otherwise         = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
240

dreixel's avatar
dreixel committed
241
    method_binds = listToBag [eq_bind, ne_bind]
242
    eq_bind = mk_FunBind loc eq_RDR (map pats_etc pat_match_cons ++ fall_through_eqn)
243
    ne_bind = mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
244
                        nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
245

246
247
248
    ------------------------------------------------------------------
    pats_etc data_con
      = let
249
250
251
252
253
254
255
256
257
258
            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)
259
      where
260
261
262
263
264
        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))
265

Austin Seipp's avatar
Austin Seipp committed
266
267
268
{-
************************************************************************
*                                                                      *
269
        Ord instances
Austin Seipp's avatar
Austin Seipp committed
270
271
*                                                                      *
************************************************************************
272

273
274
Note [Generating Ord instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
275
Suppose constructors are K1..Kn, and some are nullary.
276
277
278
The general form we generate is:

* Do case on first argument
279
        case a of
280
281
282
283
284
285
286
          K1 ... -> rhs_1
          K2 ... -> rhs_2
          ...
          Kn ... -> rhs_n
          _ -> nullary_rhs

* To make rhs_i
287
288
     If i = 1, 2, n-1, n, generate a single case.
        rhs_2    case b of
289
290
291
292
293
294
295
296
                   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
297
                 else case b of
298
299
300
                         K3 ... -> ...eq_rhs(K3)....
                         _      -> LT

301
* To make eq_rhs(K), which knows that
302
303
304
305
306
307
    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
308
309
     case con2tag a of a# ->
     case con2tag b of ->
310
311
312
313
314
315
316
     a# `compare` b#

Several special cases:

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

* Be careful about unlifted comparisons.  When comparing unboxed
317
  values we can't call the overloaded functions.
318
319
320
321
322
  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
323
comparisons on top of it; see Trac #2130, #4019.  Reason: we don't
324
325
326
327
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
328
                            False -> case ==# x y of
329
330
                                       True  -> False
                                       False -> True
331

332
So for sufficiently small types (few constructors, or all nullary)
333
we generate all methods; for large ones we just use 'compare'.
Austin Seipp's avatar
Austin Seipp committed
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
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
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
376
gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
377
gen_Ord_binds loc tycon
378
  | null tycon_data_cons        -- No data-cons => invoke bale-out case
dreixel's avatar
dreixel committed
379
  = (unitBag $ mk_FunBind loc compare_RDR [], emptyBag)
380
  | otherwise
dreixel's avatar
dreixel committed
381
  = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
382
  where
383
    aux_binds | single_con_type = emptyBag
384
              | otherwise       = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
385

386
387
388
        -- 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
389
              = listToBag (map mkOrdOp [OrdLT,OrdLE,OrdGE,OrdGT])
390
              | otherwise
391
              = emptyBag
392

393
394
395
    get_tag con = dataConTag con - fIRST_TAG
        -- We want *zero-based* tags, because that's what
        -- con2Tag returns (generated by untag_Expr)!
396

397
398
399
400
    tycon_data_cons = tyConDataCons tycon
    single_con_type = isSingleton tycon_data_cons
    (first_con : _) = tycon_data_cons
    (last_con : _)  = reverse tycon_data_cons
401
402
    first_tag       = get_tag first_con
    last_tag        = get_tag last_con
403

404
    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
405

406

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

411
    mkOrdOpRhs :: OrdOp -> LHsExpr RdrName
412
    mkOrdOpRhs op       -- RHS for comparing 'a' and 'b' according to op
413
      | length nullary_cons <= 2  -- Two nullary or fewer, so use cases
414
      = nlHsCase (nlHsVar a_RDR) $
415
        map (mkOrdOpAlt op) tycon_data_cons
416
        -- i.e.  case a of { C1 x y -> case b of C1 x y -> ....compare x,y...
417
        --                   C2 x   -> case b of C2 x -> ....comopare x.... }
418

419
420
      | null non_nullary_cons    -- All nullary, so go straight to comparing tags
      = mkTagCmp op
421

422
      | otherwise                -- Mixed nullary and non-nullary
423
      = nlHsCase (nlHsVar a_RDR) $
424
        (map (mkOrdOpAlt op) non_nullary_cons
425
         ++ [mkSimpleHsAlt nlWildPat (mkTagCmp op)])
426

427

428
    mkOrdOpAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
429
    -- Make the alternative  (Ki a1 a2 .. av ->
430
431
432
433
434
435
436
437
438
439
440
441
442
    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) ]
443
      | tag == last_tag
444
445
      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
                                 , mkSimpleHsAlt nlWildPat (gtResult op) ]
446

447
448
449
450
451
452
453
454
455
      | 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) ]

456
      | tag > last_tag `div` 2  -- lower range is larger
457
      = untag_Expr tycon [(b_RDR, bh_RDR)] $
458
        nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
459
               (gtResult op) $  -- Definitely GT
460
461
        nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
                                 , mkSimpleHsAlt nlWildPat (ltResult op) ]
462
463

      | otherwise               -- upper range is larger
464
      = untag_Expr tycon [(b_RDR, bh_RDR)] $
465
        nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
466
               (ltResult op) $  -- Definitely LT
467
468
469
        nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
                                 , mkSimpleHsAlt nlWildPat (gtResult op) ]
      where
470
        tag     = get_tag data_con
471
        tag_lit = noLoc (HsLit (HsIntPrim "" (toInteger tag)))
472

473
    mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
474
475
476
477
    -- 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) $
478
        mkCompareFields tycon op (dataConOrigArgTys data_con)
479
480
481
482
      where
        data_con_RDR = getRdrName data_con
        bs_needed    = take (dataConSourceArity data_con) bs_RDRs

483
    mkTagCmp :: OrdOp -> LHsExpr RdrName
484
485
486
487
    -- 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
488

489
490
491
492
493
494
495
496
497
498
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)
499
500
    go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
                                  (ltResult op)
501
                                  (go tys as bs)
502
                                  (gtResult op)
503
504
505
506
    go _ _ _ = panic "mkCompareFields"

    -- (mk_compare ty a b) generates
    --    (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })
507
    -- but with suitable special cases for
508
509
510
    mk_compare ty a b lt eq gt
      | isUnLiftedType ty
      = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
511
      | otherwise
512
513
514
515
516
517
518
519
520
521
522
523
      = 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
524
       OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
525
526
527
528
529
530
531
                                     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
532
   wrap prim_op = genPrimOpApp a_expr prim_op b_expr
533
534
535
   a_expr = nlHsVar a
   b_expr = nlHsVar b

536
unliftedCompare :: RdrName -> RdrName
537
                -> LHsExpr RdrName -> LHsExpr RdrName   -- What to cmpare
538
539
540
541
                -> 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
542
  = nlHsIf (genPrimOpApp a_expr lt_op b_expr) lt $
Gabor Greif's avatar
typos    
Gabor Greif committed
543
                        -- Test (<) first, not (==), because the latter
544
545
                        -- is true less often, so putting it first would
                        -- mean more tests (dynamically)
546
        nlHsIf (genPrimOpApp a_expr eq_op b_expr) eq gt
547
548
549
550

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

Austin Seipp's avatar
Austin Seipp committed
554
555
556
{-
************************************************************************
*                                                                      *
557
        Enum instances
Austin Seipp's avatar
Austin Seipp committed
558
559
*                                                                      *
************************************************************************
560
561
562
563
564
565
566
567
568
569
570

@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
571
572
573
    succ x   = toEnum (1 + fromEnum x)
    pred x   = toEnum (fromEnum x - 1)

574
575
    toEnum i = tag2con_Foo i

576
577
578
579
580
    enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]

    -- or, really...
    enumFrom a
      = case con2tag_Foo a of
581
          a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
582
583
584
585
586
587
588

   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# ->
589
590
591
        case con2tag_Foo b of { b# ->
        map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
        }}
592
593
594
\end{verbatim}

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

dreixel's avatar
dreixel committed
597
gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
598
gen_Enum_binds loc tycon
dreixel's avatar
dreixel committed
599
  = (method_binds, aux_binds)
600
  where
dreixel's avatar
dreixel committed
601
    method_binds = listToBag [
602
603
604
605
606
607
608
                        succ_enum,
                        pred_enum,
                        to_enum,
                        enum_from,
                        enum_from_then,
                        from_enum
                    ]
609
610
    aux_binds = listToBag $ map DerivAuxBind
                  [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
611

612
    occ_nm = getOccString tycon
sof's avatar
sof committed
613
614

    succ_enum
615
      = mk_easy_FunBind loc succ_RDR [a_Pat] $
616
617
618
619
620
621
622
623
        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
624
    pred_enum
625
      = mk_easy_FunBind loc pred_RDR [a_Pat] $
626
627
628
629
630
631
        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],
632
                                               nlHsLit (HsInt "-1" (-1))]))
633
634

    to_enum
635
      = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
636
637
        nlHsIf (nlHsApps and_RDR
                [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
638
639
                 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
             (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
640
             (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
641

642
    enum_from
643
      = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
644
645
646
647
648
649
          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)))]
650
651

    enum_from_then
652
      = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
653
654
655
656
657
658
659
660
661
662
          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))
                           ))
663
664

    from_enum
665
      = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
666
667
          untag_Expr tycon [(a_RDR, ah_RDR)] $
          (nlHsVarApps intDataCon_RDR [ah_RDR])
668

Austin Seipp's avatar
Austin Seipp committed
669
670
671
{-
************************************************************************
*                                                                      *
672
        Bounded instances
Austin Seipp's avatar
Austin Seipp committed
673
674
675
*                                                                      *
************************************************************************
-}
676

dreixel's avatar
dreixel committed
677
gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
678
gen_Bounded_binds loc tycon
679
  | isEnumerationTyCon tycon
dreixel's avatar
dreixel committed
680
  = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
681
682
  | otherwise
  = ASSERT(isSingleton data_cons)
dreixel's avatar
dreixel committed
683
    (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)
684
  where
685
    data_cons = tyConDataCons tycon
686
687

    ----- enum-flavored: ---------------------------
688
689
    min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
    max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
690

691
692
    data_con_1     = head data_cons
    data_con_N     = last data_cons
693
694
    data_con_1_RDR = getRdrName data_con_1
    data_con_N_RDR = getRdrName data_con_N
695
696

    ----- single-constructor-flavored: -------------
697
    arity          = dataConSourceArity data_con_1
698

699
    min_bound_1con = mkHsVarBind loc minBound_RDR $
700
                     nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
701
    max_bound_1con = mkHsVarBind loc maxBound_RDR $
702
                     nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
703

Austin Seipp's avatar
Austin Seipp committed
704
705
706
{-
************************************************************************
*                                                                      *
707
        Ix instances
Austin Seipp's avatar
Austin Seipp committed
708
709
*                                                                      *
************************************************************************
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726

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# ->
727
728
729
        case (con2tag_Foo b) of { b# ->
        map tag2con_Foo (enumFromTo (I# a#) (I# b#))
        }}
730

Gabor Greif's avatar
typos    
Gabor Greif committed
731
    -- Generate code for unsafeIndex, because using index leads
732
733
734
    -- to lots of redundant range tests
    unsafeIndex c@(a, b) d
      = case (con2tag_Foo d -# con2tag_Foo a) of
735
               r# -> I# r#
736
737
738

    inRange (a, b) c
      = let
739
740
741
            p_tag = con2tag_Foo c
        in
        p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
742
743
744
745

    -- or, really...
    inRange (a, b) c
      = case (con2tag_Foo a)   of { a_tag ->
746
747
748
749
750
751
752
        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
        }}}
753
\end{verbatim}
754
(modulo suitable case-ification to handle the unlifted tags)
755
756
757
758
759
760
761

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
762
-}
763

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

766
gen_Ix_binds loc tycon
767
  | isEnumerationTyCon tycon
768
769
770
  = ( enum_ixes
    , listToBag $ map DerivAuxBind
                   [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
771
  | otherwise
772
  = (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))
773
774
  where
    --------------------------------------------------------------
dreixel's avatar
dreixel committed
775
    enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
776
777

    enum_range
778
      = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
779
780
781
782
783
784
          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]))
785
786

    enum_index
787
788
789
790
791
792
793
794
795
796
797
798
799
800
      = 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]
           ))
        )
801
802

    enum_inRange
803
      = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
804
805
806
          untag_Expr tycon [(a_RDR, ah_RDR)] (
          untag_Expr tycon [(b_RDR, bh_RDR)] (
          untag_Expr tycon [(c_RDR, ch_RDR)] (
807
808
          nlHsIf (genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
             (genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
809
810
811
          ) {-else-} (
             false_Expr
          ))))
812
813

    --------------------------------------------------------------
814
    single_con_ixes
dreixel's avatar
dreixel committed
815
      = listToBag [single_con_range, single_con_index, single_con_inRange]
816
817

    data_con
818
819
820
      = case tyConSingleDataCon_maybe tycon of -- just checking...
          Nothing -> panic "get_Ix_binds"
          Just dc -> dc
821

822
    con_arity    = dataConSourceArity data_con
823
    data_con_RDR = getRdrName data_con
824

825
826
827
    as_needed = take con_arity as_RDRs
    bs_needed = take con_arity bs_RDRs
    cs_needed = take con_arity cs_RDRs
828

829
830
    con_pat  xs  = nlConVarPat data_con_RDR xs
    con_expr     = nlHsVarApps data_con_RDR cs_needed
sof's avatar
sof committed
831

832
833
    --------------------------------------------------------------
    single_con_range
834
835
836
      = mk_easy_FunBind loc range_RDR
          [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
        noLoc (mkHsComp ListComp stmts con_expr)
837
      where
838
        stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
839

840
841
842
        mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
                                 (nlHsApp (nlHsVar range_RDR)
                                          (mkLHsVarTuple [a,b]))
843
844
845

    ----------------
    single_con_index
846
847
848
      = mk_easy_FunBind loc unsafeIndex_RDR
                [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
                 con_pat cs_needed]
849
850
851
852
        -- 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.
853
                (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
854
      where
855
856
857
858
859
860
861
862
863
864
865
866
867
868
        -- 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]
869
870
871

    ------------------
    single_con_inRange
872
873
874
875
      = 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)
876
      where
877
        in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
878

Austin Seipp's avatar
Austin Seipp committed
879
880
881
{-
************************************************************************
*                                                                      *
882
        Read instances
Austin Seipp's avatar
Austin Seipp committed
883
884
*                                                                      *
************************************************************************
885

886
887
888
889
Example

  infix 4 %%
  data T = Int %% Int
890
891
         | T1 { f1 :: Int }
         | T2 T
892
893
894

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

  readListPrec = readListPrecDefault
  readList     = readListDefault


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

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

953
gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
954

955
gen_Read_binds get_fixity loc tycon
dreixel's avatar
dreixel committed
956
  = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
957
  where
958
    -----------------------------------------------------------------------
959
960
    default_readlist
        = mkHsVarBind loc readList_RDR     (nlHsVar readListDefault_RDR)
961
962

    default_readlistprec
963
        = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
964
    -----------------------------------------------------------------------
965
966

    data_cons = tyConDataCons tycon
967
    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
968

969
    read_prec = mkHsVarBind loc readPrec_RDR
970
                              (nlHsApp (nlHsVar parens_RDR) read_cons)
971

972
    read_cons | null data_cons = nlHsVar pfail_RDR  -- See Note [Read for empty data types]
973
              | otherwise      = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
974
    read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
975
976

    read_nullary_cons
977
      = case nullary_cons of
978
979
980
981
            []    -> []
            [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])]
            _     -> [nlHsApp (nlHsVar choose_RDR)
                              (nlList (map mk_pair nullary_cons))]
982
        -- NB For operators the parens around (:=:) are matched by the
983
984
        -- enclosing "parens" call, so here we must match the naked
        -- data_con_str con
985

986
987
    match_con con | isSym con_str = [symbol_pat con_str]
                  | otherwise     = ident_h_pat  con_str
988
989
                  where
                    con_str = data_con_str con
990
991
        -- For nullary constructors we must match Ident s for normal constrs
        -- and   Symbol s   for operators
992

993
994
    mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),
                                  result_expr con []]
995

996
    read_non_nullary_con data_con
997
998
      | is_infix  = mk_parser infix_prec  infix_stmts  body
      | is_record = mk_parser record_prec record_stmts body
999
1000
--              Using these two lines instead allows the derived
--              read for infix and record bindings to read the prefix form
1001
1002
1003
--      | 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
1004
      where
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041