TcGenDeriv.hs 83 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(..),

Ryan Scott's avatar
Ryan Scott committed
21 22 23 24 25 26 27 28 29
        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,
30
        gen_Newtype_binds,
Ryan Scott's avatar
Ryan Scott committed
31
        mkCoerceClassMethEqn,
32
        genAuxBinds,
Ryan Scott's avatar
Ryan Scott committed
33
        ordOpTbl, boxConTbl, litConTbl,
Ryan Scott's avatar
Ryan Scott committed
34
        mkRdrFunBind, error_Expr
35
    ) where
36

37
#include "HsVersions.h"
38

39
import TcRnMonad
40
import HsSyn
41 42 43 44
import RdrName
import BasicTypes
import DataCon
import Name
niteria's avatar
niteria committed
45 46
import Fingerprint
import Encoding
47

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

78
import Data.List  ( partition, intersperse )
79

80 81
type BagDerivStuff = Bag DerivStuff

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

90 91 92
data DerivStuff     -- Please add this auxiliary stuff
  = DerivAuxBind AuxBindSpec

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

96
  -- New top-level auxiliary bindings
97
  | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB
98

99

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

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

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

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

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

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

142
     (==) a b  = False
143

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

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

dreixel's avatar
dreixel committed
159
gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
160
gen_Eq_binds loc tycon
dreixel's avatar
dreixel committed
161
  = (method_binds, aux_binds)
162
  where
163 164 165 166 167 168 169 170 171
    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)
172

173
    no_tag_match_cons = null tag_match_cons
174

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

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

190 191
    aux_binds | no_tag_match_cons = emptyBag
              | otherwise         = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
192

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

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

            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)
211
      where
212 213 214 215 216
        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))
217

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

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

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

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

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

Several special cases:

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

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

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

284 285 286 287 288 289 290
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

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

Austin Seipp's avatar
Austin Seipp committed
294
-}
295

296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335
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
336
gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
337
gen_Ord_binds loc tycon
338
  | null tycon_data_cons        -- No data-cons => invoke bale-out case
dreixel's avatar
dreixel committed
339
  = (unitBag $ mk_FunBind loc compare_RDR [], emptyBag)
340
  | otherwise
dreixel's avatar
dreixel committed
341
  = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
342
  where
343
    aux_binds | single_con_type = emptyBag
344
              | otherwise       = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
345

346
        -- Note [Game plan for deriving Ord]
347 348
    other_ops | (last_tag - first_tag) <= 2     -- 1-3 constructors
                || null non_nullary_cons        -- Or it's an enumeration
349
              = listToBag [mkOrdOp OrdLT, lE, gT, gE]
350
              | otherwise
351
              = emptyBag
352

353 354 355 356 357 358 359 360
    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)

361 362 363
    get_tag con = dataConTag con - fIRST_TAG
        -- We want *zero-based* tags, because that's what
        -- con2Tag returns (generated by untag_Expr)!
364

365 366 367 368
    tycon_data_cons = tyConDataCons tycon
    single_con_type = isSingleton tycon_data_cons
    (first_con : _) = tycon_data_cons
    (last_con : _)  = reverse tycon_data_cons
369 370
    first_tag       = get_tag first_con
    last_tag        = get_tag last_con
371

372
    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
373

374

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

379
    mkOrdOpRhs :: OrdOp -> LHsExpr RdrName
380
    mkOrdOpRhs op       -- RHS for comparing 'a' and 'b' according to op
381
      | length nullary_cons <= 2  -- Two nullary or fewer, so use cases
382
      = nlHsCase (nlHsVar a_RDR) $
383
        map (mkOrdOpAlt op) tycon_data_cons
384
        -- i.e.  case a of { C1 x y -> case b of C1 x y -> ....compare x,y...
385
        --                   C2 x   -> case b of C2 x -> ....comopare x.... }
386

387 388
      | null non_nullary_cons    -- All nullary, so go straight to comparing tags
      = mkTagCmp op
389

390
      | otherwise                -- Mixed nullary and non-nullary
391
      = nlHsCase (nlHsVar a_RDR) $
392
        (map (mkOrdOpAlt op) non_nullary_cons
393
         ++ [mkHsCaseAlt nlWildPat (mkTagCmp op)])
394

395

396
    mkOrdOpAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
397
    -- Make the alternative  (Ki a1 a2 .. av ->
398
    mkOrdOpAlt op data_con
399 400
      = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed)
                    (mkInnerRhs op data_con)
401 402 403 404 405 406 407 408 409 410
      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
411
                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
412
      | tag == last_tag
413
      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
414
                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
415

416
      | tag == first_tag + 1
417 418
      = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat first_con)
                                             (gtResult op)
419
                                 , mkInnerEqAlt op data_con
420
                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
421
      | tag == last_tag - 1
422 423
      = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat last_con)
                                             (ltResult op)
424
                                 , mkInnerEqAlt op data_con
425
                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
426

427
      | tag > last_tag `div` 2  -- lower range is larger
428
      = untag_Expr tycon [(b_RDR, bh_RDR)] $
429
        nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
430
               (gtResult op) $  -- Definitely GT
431
        nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
432
                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
433 434

      | otherwise               -- upper range is larger
435
      = untag_Expr tycon [(b_RDR, bh_RDR)] $
436
        nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
437
               (ltResult op) $  -- Definitely LT
438
        nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
439
                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
440
      where
441
        tag     = get_tag data_con
Alan Zimmerman's avatar
Alan Zimmerman committed
442
        tag_lit = noLoc (HsLit (HsIntPrim NoSourceText (toInteger tag)))
443

444
    mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
445 446 447
    -- 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
448
      = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $
449
        mkCompareFields tycon op (dataConOrigArgTys data_con)
450 451 452 453
      where
        data_con_RDR = getRdrName data_con
        bs_needed    = take (dataConSourceArity data_con) bs_RDRs

454
    mkTagCmp :: OrdOp -> LHsExpr RdrName
455 456 457 458
    -- 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
459

460 461 462 463 464 465 466 467
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:_)
468
      | isUnliftedType ty     = unliftedOrdOp tycon ty op a b
469
      | otherwise             = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)
470 471
    go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
                                  (ltResult op)
472
                                  (go tys as bs)
473
                                  (gtResult op)
474 475 476 477
    go _ _ _ = panic "mkCompareFields"

    -- (mk_compare ty a b) generates
    --    (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })
478
    -- but with suitable special cases for
479
    mk_compare ty a b lt eq gt
480
      | isUnliftedType ty
481
      = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
482
      | otherwise
483
      = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr))
484 485 486
          [mkHsCaseAlt (nlNullaryConPat ltTag_RDR) lt,
           mkHsCaseAlt (nlNullaryConPat eqTag_RDR) eq,
           mkHsCaseAlt (nlNullaryConPat gtTag_RDR) gt]
487 488 489 490 491 492 493 494
      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
495
       OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
496 497 498 499 500 501 502
                                     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
503
   wrap prim_op = genPrimOpApp a_expr prim_op b_expr
504 505 506
   a_expr = nlHsVar a
   b_expr = nlHsVar b

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

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

Austin Seipp's avatar
Austin Seipp committed
527 528 529
{-
************************************************************************
*                                                                      *
530
        Enum instances
Austin Seipp's avatar
Austin Seipp committed
531 532
*                                                                      *
************************************************************************
533 534 535 536 537 538 539 540 541 542 543

@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
544 545 546
    succ x   = toEnum (1 + fromEnum x)
    pred x   = toEnum (fromEnum x - 1)

547 548
    toEnum i = tag2con_Foo i

549 550 551 552 553
    enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]

    -- or, really...
    enumFrom a
      = case con2tag_Foo a of
554
          a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
555 556 557 558 559 560 561

   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# ->
562 563 564
        case con2tag_Foo b of { b# ->
        map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
        }}
565 566 567
\end{verbatim}

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

dreixel's avatar
dreixel committed
570
gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
571
gen_Enum_binds loc tycon
dreixel's avatar
dreixel committed
572
  = (method_binds, aux_binds)
573
  where
dreixel's avatar
dreixel committed
574
    method_binds = listToBag [
575 576 577 578 579 580 581
                        succ_enum,
                        pred_enum,
                        to_enum,
                        enum_from,
                        enum_from_then,
                        from_enum
                    ]
582 583
    aux_binds = listToBag $ map DerivAuxBind
                  [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
584

585
    occ_nm = getOccString tycon
sof's avatar
sof committed
586 587

    succ_enum
588
      = mk_easy_FunBind loc succ_RDR [a_Pat] $
589 590 591 592 593 594 595 596
        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
597
    pred_enum
598
      = mk_easy_FunBind loc pred_RDR [a_Pat] $
599 600 601 602 603 604
        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],
Alan Zimmerman's avatar
Alan Zimmerman committed
605
                                           nlHsLit (HsInt NoSourceText (-1))]))
606 607

    to_enum
608
      = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
609 610
        nlHsIf (nlHsApps and_RDR
                [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
611 612
                 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
             (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
613
             (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
614

615
    enum_from
616
      = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
617 618 619 620 621 622
          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)))]
623 624

    enum_from_then
625
      = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
626 627 628 629 630 631 632 633 634 635
          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))
                           ))
636 637

    from_enum
638
      = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
639 640
          untag_Expr tycon [(a_RDR, ah_RDR)] $
          (nlHsVarApps intDataCon_RDR [ah_RDR])
641

Austin Seipp's avatar
Austin Seipp committed
642 643 644
{-
************************************************************************
*                                                                      *
645
        Bounded instances
Austin Seipp's avatar
Austin Seipp committed
646 647 648
*                                                                      *
************************************************************************
-}
649

dreixel's avatar
dreixel committed
650
gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
651
gen_Bounded_binds loc tycon
652
  | isEnumerationTyCon tycon
dreixel's avatar
dreixel committed
653
  = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
654 655
  | otherwise
  = ASSERT(isSingleton data_cons)
dreixel's avatar
dreixel committed
656
    (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)
657
  where
658
    data_cons = tyConDataCons tycon
659 660

    ----- enum-flavored: ---------------------------
661 662
    min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
    max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
663

664 665
    data_con_1     = head data_cons
    data_con_N     = last data_cons
666 667
    data_con_1_RDR = getRdrName data_con_1
    data_con_N_RDR = getRdrName data_con_N
668 669

    ----- single-constructor-flavored: -------------
670
    arity          = dataConSourceArity data_con_1
671

672
    min_bound_1con = mkHsVarBind loc minBound_RDR $
673
                     nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
674
    max_bound_1con = mkHsVarBind loc maxBound_RDR $
675
                     nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
676

Austin Seipp's avatar
Austin Seipp committed
677 678 679
{-
************************************************************************
*                                                                      *
680
        Ix instances
Austin Seipp's avatar
Austin Seipp committed
681 682
*                                                                      *
************************************************************************
683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699

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# ->
700 701 702
        case (con2tag_Foo b) of { b# ->
        map tag2con_Foo (enumFromTo (I# a#) (I# b#))
        }}
703

Gabor Greif's avatar
typos  
Gabor Greif committed
704
    -- Generate code for unsafeIndex, because using index leads
705 706 707
    -- to lots of redundant range tests
    unsafeIndex c@(a, b) d
      = case (con2tag_Foo d -# con2tag_Foo a) of
708
               r# -> I# r#
709 710 711

    inRange (a, b) c
      = let
712 713 714
            p_tag = con2tag_Foo c
        in
        p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
715 716 717 718

    -- or, really...
    inRange (a, b) c
      = case (con2tag_Foo a)   of { a_tag ->
719 720 721 722 723 724 725
        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
        }}}
726
\end{verbatim}
727
(modulo suitable case-ification to handle the unlifted tags)
728 729 730 731 732 733 734

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
735
-}
736

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

739
gen_Ix_binds loc tycon
740
  | isEnumerationTyCon tycon
741 742 743
  = ( enum_ixes
    , listToBag $ map DerivAuxBind
                   [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
744
  | otherwise
745
  = (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))
746 747
  where
    --------------------------------------------------------------
dreixel's avatar
dreixel committed
748
    enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
749 750

    enum_range
751
      = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
752 753 754 755 756 757
          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]))
758 759

    enum_index
760 761 762 763 764 765 766 767 768 769 770
      = 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))
771
             [mkHsCaseAlt (nlVarPat c_RDR) rhs]
772 773
           ))
        )
774

775
    -- This produces something like `(ch >= ah) && (ch <= bh)`
776
    enum_inRange
777
      = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
778 779 780
          untag_Expr tycon [(a_RDR, ah_RDR)] (
          untag_Expr tycon [(b_RDR, bh_RDR)] (
          untag_Expr tycon [(c_RDR, ch_RDR)] (
781 782 783 784 785 786 787
          -- 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)
              ]
          )))
788 789

    --------------------------------------------------------------
790
    single_con_ixes
dreixel's avatar
dreixel committed
791
      = listToBag [single_con_range, single_con_index, single_con_inRange]
792 793

    data_con
794 795 796
      = case tyConSingleDataCon_maybe tycon of -- just checking...
          Nothing -> panic "get_Ix_binds"
          Just dc -> dc
797

798
    con_arity    = dataConSourceArity data_con
799
    data_con_RDR = getRdrName data_con
800

801 802 803
    as_needed = take con_arity as_RDRs
    bs_needed = take con_arity bs_RDRs
    cs_needed = take con_arity cs_RDRs
804

805 806
    con_pat  xs  = nlConVarPat data_con_RDR xs
    con_expr     = nlHsVarApps data_con_RDR cs_needed
sof's avatar
sof committed
807

808 809
    --------------------------------------------------------------
    single_con_range
810 811 812
      = mk_easy_FunBind loc range_RDR
          [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
        noLoc (mkHsComp ListComp stmts con_expr)
813
      where
814
        stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
815

816 817 818
        mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
                                 (nlHsApp (nlHsVar range_RDR)
                                          (mkLHsVarTuple [a,b]))
819 820 821

    ----------------
    single_con_index
822 823 824
      = mk_easy_FunBind loc unsafeIndex_RDR
                [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
                 con_pat cs_needed]
825 826 827 828
        -- 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.
829
                (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
830
      where
831 832 833 834 835 836 837 838 839 840 841 842 843 844
        -- 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]
845 846 847

    ------------------
    single_con_inRange
848 849 850
      = mk_easy_FunBind loc inRange_RDR
                [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
                 con_pat cs_needed] $
851 852 853 854 855 856
          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)
857
      where
858
        in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
859

Austin Seipp's avatar
Austin Seipp committed
860 861 862
{-
************************************************************************
*                                                                      *
863
        Read instances
Austin Seipp's avatar
Austin Seipp committed
864 865
*                                                                      *
************************************************************************