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

6 7

TcGenDeriv: Generating derived instance declarations
8 9 10 11 12

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

This is where we do all the grimy bindings' generation.
Austin Seipp's avatar
Austin Seipp committed
13
-}
14

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

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

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

31
#include "HsVersions.h"
32

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

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

71 72
import ListSetOps ( assocMaybe )
import Data.List  ( partition, intersperse )
73
import Data.Maybe ( catMaybes, isJust )
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
Simon Peyton Jones's avatar
Simon Peyton Jones committed
89
  | DerivFamInst FamInst               -- New type family instances
90

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

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

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

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

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

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

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

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

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

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

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

175
     (==) a b  = False
176

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

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

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

206
    no_tag_match_cons = null tag_match_cons
207

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

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

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

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

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

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

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

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

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

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

Several special cases:

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

* Be careful about unlifted comparisons.  When comparing unboxed
302
  values we can't call the overloaded functions.
303 304 305 306 307
  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
308
comparisons on top of it; see Trac #2130, #4019.  Reason: we don't
309 310 311 312
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
313
                            False -> case ==# x y of
314 315
                                       True  -> False
                                       False -> True
316

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

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

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

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

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

389
    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
390

391

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

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

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

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

412

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

433
      | tag == first_tag + 1
434 435
      = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat first_con)
                                             (gtResult op)
436
                                 , mkInnerEqAlt op data_con
437
                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
438
      | tag == last_tag - 1
439 440
      = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat last_con)
                                             (ltResult op)
441
                                 , mkInnerEqAlt op data_con
442
                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
443

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

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

461
    mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
462 463 464
    -- 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
465
      = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $
466
        mkCompareFields tycon op (dataConOrigArgTys data_con)
467 468 469 470
      where
        data_con_RDR = getRdrName data_con
        bs_needed    = take (dataConSourceArity data_con) bs_RDRs

471
    mkTagCmp :: OrdOp -> LHsExpr RdrName
472 473 474 475
    -- 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
476

477 478 479 480 481 482 483 484
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:_)
485
      | isUnliftedType ty     = unliftedOrdOp tycon ty op a b
486
      | otherwise             = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)
487 488
    go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
                                  (ltResult op)
489
                                  (go tys as bs)
490
                                  (gtResult op)
491 492 493 494
    go _ _ _ = panic "mkCompareFields"

    -- (mk_compare ty a b) generates
    --    (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })
495
    -- but with suitable special cases for
496
    mk_compare ty a b lt eq gt
497
      | isUnliftedType ty
498
      = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
499
      | otherwise
500
      = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr))
501 502 503
          [mkHsCaseAlt (nlNullaryConPat ltTag_RDR) lt,
           mkHsCaseAlt (nlNullaryConPat eqTag_RDR) eq,
           mkHsCaseAlt (nlNullaryConPat gtTag_RDR) gt]
504 505 506 507 508 509 510 511
      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
512
       OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
513 514 515 516 517 518 519
                                     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
520
   wrap prim_op = genPrimOpApp a_expr prim_op b_expr
521 522 523
   a_expr = nlHsVar a
   b_expr = nlHsVar b

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

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

Austin Seipp's avatar
Austin Seipp committed
544 545 546
{-
************************************************************************
*                                                                      *
547
        Enum instances
Austin Seipp's avatar
Austin Seipp committed
548 549
*                                                                      *
************************************************************************
550 551 552 553 554 555 556 557 558 559 560

@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
561 562 563
    succ x   = toEnum (1 + fromEnum x)
    pred x   = toEnum (fromEnum x - 1)

564 565
    toEnum i = tag2con_Foo i

566 567 568 569 570
    enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]

    -- or, really...
    enumFrom a
      = case con2tag_Foo a of
571
          a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
572 573 574 575 576 577 578

   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# ->
579 580 581
        case con2tag_Foo b of { b# ->
        map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
        }}
582 583 584
\end{verbatim}

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

dreixel's avatar
dreixel committed
587
gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
588
gen_Enum_binds loc tycon
dreixel's avatar
dreixel committed
589
  = (method_binds, aux_binds)
590
  where
dreixel's avatar
dreixel committed
591
    method_binds = listToBag [
592 593 594 595 596 597 598
                        succ_enum,
                        pred_enum,
                        to_enum,
                        enum_from,
                        enum_from_then,
                        from_enum
                    ]
599 600
    aux_binds = listToBag $ map DerivAuxBind
                  [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
601

602
    occ_nm = getOccString tycon
sof's avatar
sof committed
603 604

    succ_enum
605
      = mk_easy_FunBind loc succ_RDR [a_Pat] $
606 607 608 609 610 611 612 613
        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
614
    pred_enum
615
      = mk_easy_FunBind loc pred_RDR [a_Pat] $
616 617 618 619 620 621
        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],
622
                                               nlHsLit (HsInt "-1" (-1))]))
623 624

    to_enum
625
      = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
626 627
        nlHsIf (nlHsApps and_RDR
                [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
628 629
                 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
             (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
630
             (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
631

632
    enum_from
633
      = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
634 635 636 637 638 639
          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)))]
640 641

    enum_from_then
642
      = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
643 644 645 646 647 648 649 650 651 652
          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))
                           ))
653 654

    from_enum
655
      = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
656 657
          untag_Expr tycon [(a_RDR, ah_RDR)] $
          (nlHsVarApps intDataCon_RDR [ah_RDR])
658

Austin Seipp's avatar
Austin Seipp committed
659 660 661
{-
************************************************************************
*                                                                      *
662
        Bounded instances
Austin Seipp's avatar
Austin Seipp committed
663 664 665
*                                                                      *
************************************************************************
-}
666

dreixel's avatar
dreixel committed
667
gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
668
gen_Bounded_binds loc tycon
669
  | isEnumerationTyCon tycon
dreixel's avatar
dreixel committed
670
  = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
671 672
  | otherwise
  = ASSERT(isSingleton data_cons)
dreixel's avatar
dreixel committed
673
    (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)
674
  where
675
    data_cons = tyConDataCons tycon
676 677

    ----- enum-flavored: ---------------------------
678 679
    min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
    max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
680

681 682
    data_con_1     = head data_cons
    data_con_N     = last data_cons
683 684
    data_con_1_RDR = getRdrName data_con_1
    data_con_N_RDR = getRdrName data_con_N
685 686

    ----- single-constructor-flavored: -------------
687
    arity          = dataConSourceArity data_con_1
688

689
    min_bound_1con = mkHsVarBind loc minBound_RDR $
690
                     nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
691
    max_bound_1con = mkHsVarBind loc maxBound_RDR $
692
                     nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
693

Austin Seipp's avatar
Austin Seipp committed
694 695 696
{-
************************************************************************
*                                                                      *
697
        Ix instances
Austin Seipp's avatar
Austin Seipp committed
698 699
*                                                                      *
************************************************************************
700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716

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# ->
717 718 719
        case (con2tag_Foo b) of { b# ->
        map tag2con_Foo (enumFromTo (I# a#) (I# b#))
        }}
720

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

    inRange (a, b) c
      = let
729 730 731
            p_tag = con2tag_Foo c
        in
        p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
732 733 734 735

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

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
752
-}
753

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

756
gen_Ix_binds loc tycon
757
  | isEnumerationTyCon tycon
758 759 760
  = ( enum_ixes
    , listToBag $ map DerivAuxBind
                   [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
761
  | otherwise
762
  = (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))
763 764
  where
    --------------------------------------------------------------
dreixel's avatar
dreixel committed
765
    enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
766 767

    enum_range
768
      = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
769 770 771 772 773 774
          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]))
775 776

    enum_index
777 778 779 780 781 782 783 784 785 786 787
      = 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))
788
             [mkHsCaseAlt (nlVarPat c_RDR) rhs]
789 790
           ))
        )
791

792
    -- This produces something like `(ch >= ah) && (ch <= bh)`
793
    enum_inRange
794
      = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
795 796 797
          untag_Expr tycon [(a_RDR, ah_RDR)] (
          untag_Expr tycon [(b_RDR, bh_RDR)] (
          untag_Expr tycon [(c_RDR, ch_RDR)] (
798 799 800 801 802 803 804
          -- 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)
              ]
          )))
805 806

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

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

815
    con_arity    = dataConSourceArity data_con
816
    data_con_RDR = getRdrName data_con
817

818 819 820
    as_needed = take con_arity as_RDRs
    bs_needed = take con_arity bs_RDRs
    cs_needed = take con_arity cs_RDRs
821

822 823
    con_pat  xs  = nlConVarPat data_con_RDR xs
    con_expr     = nlHsVarApps data_con_RDR cs_needed
sof's avatar
sof committed
824

825 826
    --------------------------------------------------------------
    single_con_range