TcGenDeriv.hs 118 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 34 35 36

import LoadIface( loadInterfaceForName )
import HscTypes( lookupFixity, mi_fix )
import TcRnMonad
37
import HsSyn
38 39
import RdrName
import BasicTypes
40
import Module( getModule )
41 42
import DataCon
import Name
niteria's avatar
niteria committed
43 44
import Fingerprint
import Encoding
45

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

75 76
import ListSetOps ( assocMaybe )
import Data.List  ( partition, intersperse )
77
import Data.Maybe ( catMaybes, isJust )
78

79 80
type BagDerivStuff = Bag DerivStuff

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

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

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

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

Austin Seipp's avatar
Austin Seipp committed
98 99 100
{-
************************************************************************
*                                                                      *
101
                Class deriving diagnostics
Austin Seipp's avatar
Austin Seipp committed
102 103
*                                                                      *
************************************************************************
104

105 106 107 108 109 110 111 112
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.
-}
113

114
hasBuiltinDeriving :: Class
115 116
                   -> Maybe (SrcSpan
                             -> TyCon
117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154
                             -> TcM (LHsBinds RdrName, BagDerivStuff))
hasBuiltinDeriving clas
  = assocMaybe gen_list (getUnique clas)
  where
    gen_list :: [(Unique, SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff))]
    gen_list = [ (eqClassKey,          simple gen_Eq_binds)
               , (ordClassKey,         simple gen_Ord_binds)
               , (enumClassKey,        simple gen_Enum_binds)
               , (boundedClassKey,     simple gen_Bounded_binds)
               , (ixClassKey,          simple gen_Ix_binds)
               , (showClassKey,        with_fix_env gen_Show_binds)
               , (readClassKey,        with_fix_env gen_Read_binds)
               , (dataClassKey,        gen_Data_binds)
               , (functorClassKey,     simple gen_Functor_binds)
               , (foldableClassKey,    simple gen_Foldable_binds)
               , (traversableClassKey, simple gen_Traversable_binds)
               , (liftClassKey,        simple gen_Lift_binds) ]

    simple gen_fn loc tc
      = return (gen_fn loc tc)

    with_fix_env gen_fn loc tc
      = do { fix_env <- getDataConFixityFun tc
           ; return (gen_fn fix_env loc tc) }

getDataConFixityFun :: TyCon -> TcM (Name -> Fixity)
-- If the TyCon is locally defined, we want the local fixity env;
-- but if it is imported (which happens for standalone deriving)
-- we need to get the fixity env from the interface file
-- c.f. RnEnv.lookupFixity, and Trac #9830
getDataConFixityFun tc
  = do { this_mod <- getModule
       ; if nameIsLocalOrFrom this_mod name
         then do { fix_env <- getFixityEnv
                 ; return (lookupFixity fix_env) }
         else do { iface <- loadInterfaceForName doc name
                            -- Should already be loaded!
                 ; return (mi_fix iface . nameOccName) } }
155
  where
156 157 158
    name = tyConName tc
    doc = text "Data con fixities for" <+> ppr name

159

Austin Seipp's avatar
Austin Seipp committed
160 161 162
{-
************************************************************************
*                                                                      *
163
                Eq instances
Austin Seipp's avatar
Austin Seipp committed
164 165
*                                                                      *
************************************************************************
166

167 168 169 170 171 172 173 174 175
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
176 177
  Usual Thing, e.g.,:

178 179 180 181 182 183 184
    (==) (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
185 186
  for that particular test.

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

190 191 192 193
      (==) a b  = case (con2tag_Foo a) of { a# ->
                  case (con2tag_Foo b) of { b# ->
                  case (a# ==# b#)     of {
                    r -> r }}}
194

195 196 197 198 199
  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
200 201
  catch-all:

202
     (==) a b  = False
203

204
* For the @(/=)@ method, we normally just use the default method.
205 206 207 208
  If the type is an enumeration type, we could/may/should? generate
  special code that calls @con2tag_Foo@, much like for @(==)@ shown
  above.

209 210 211 212 213 214 215 216
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
217
-}
sof's avatar
sof committed
218

dreixel's avatar
dreixel committed
219
gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
220
gen_Eq_binds loc tycon
dreixel's avatar
dreixel committed
221
  = (method_binds, aux_binds)
222
  where
223 224 225 226 227 228 229 230 231
    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)
232

233
    no_tag_match_cons = null tag_match_cons
234

235
    fall_through_eqn
236 237
      | no_tag_match_cons   -- All constructors have arguments
      = case pat_match_cons of
238
          []  -> []   -- No constructors; no fall-though case
239
          [_] -> []   -- One constructor; no fall-though case
240
          _   ->      -- Two or more constructors; add fall-through of
241 242
                      --       (==) _ _ = False
                 [([nlWildPat, nlWildPat], false_Expr)]
243

244
      | otherwise -- One or more tag_match cons; add fall-through of
245 246
                  -- extract tags compare for equality
      = [([a_Pat, b_Pat],
247
         untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
248
                    (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
249

250 251
    aux_binds | no_tag_match_cons = emptyBag
              | otherwise         = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
252

dreixel's avatar
dreixel committed
253
    method_binds = listToBag [eq_bind, ne_bind]
254
    eq_bind = mk_FunBind loc eq_RDR (map pats_etc pat_match_cons ++ fall_through_eqn)
255
    ne_bind = mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
256
                        nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
257

258 259 260
    ------------------------------------------------------------------
    pats_etc data_con
      = let
261 262 263 264 265 266 267 268 269 270
            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)
271
      where
272 273 274 275 276
        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))
277

Austin Seipp's avatar
Austin Seipp committed
278 279 280
{-
************************************************************************
*                                                                      *
281
        Ord instances
Austin Seipp's avatar
Austin Seipp committed
282 283
*                                                                      *
************************************************************************
284

285 286
Note [Generating Ord instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
287
Suppose constructors are K1..Kn, and some are nullary.
288 289 290
The general form we generate is:

* Do case on first argument
291
        case a of
292 293 294 295 296 297 298
          K1 ... -> rhs_1
          K2 ... -> rhs_2
          ...
          Kn ... -> rhs_n
          _ -> nullary_rhs

* To make rhs_i
299 300
     If i = 1, 2, n-1, n, generate a single case.
        rhs_2    case b of
301 302 303 304 305 306 307 308
                   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
309
                 else case b of
310 311 312
                         K3 ... -> ...eq_rhs(K3)....
                         _      -> LT

313
* To make eq_rhs(K), which knows that
314 315 316 317 318 319
    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
320 321
     case con2tag a of a# ->
     case con2tag b of ->
322 323 324 325 326 327 328
     a# `compare` b#

Several special cases:

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

* Be careful about unlifted comparisons.  When comparing unboxed
329
  values we can't call the overloaded functions.
330 331
  See function unliftedOrdOp

332
Note [Game plan for deriving Ord]
333 334
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's a bad idea to define only 'compare', and build the other binary
Gabor Greif's avatar
Gabor Greif committed
335
comparisons on top of it; see Trac #2130, #4019.  Reason: we don't
336 337 338 339
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
340
                            False -> case ==# x y of
341 342
                                       True  -> False
                                       False -> True
343

344 345 346 347 348 349 350
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

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

Austin Seipp's avatar
Austin Seipp committed
354
-}
355

356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395
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
396
gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
397
gen_Ord_binds loc tycon
398
  | null tycon_data_cons        -- No data-cons => invoke bale-out case
dreixel's avatar
dreixel committed
399
  = (unitBag $ mk_FunBind loc compare_RDR [], emptyBag)
400
  | otherwise
dreixel's avatar
dreixel committed
401
  = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
402
  where
403
    aux_binds | single_con_type = emptyBag
404
              | otherwise       = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
405

406
        -- Note [Game plan for deriving Ord]
407 408
    other_ops | (last_tag - first_tag) <= 2     -- 1-3 constructors
                || null non_nullary_cons        -- Or it's an enumeration
409
              = listToBag [mkOrdOp OrdLT, lE, gT, gE]
410
              | otherwise
411
              = emptyBag
412

413 414 415 416 417 418 419 420
    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)

421 422 423
    get_tag con = dataConTag con - fIRST_TAG
        -- We want *zero-based* tags, because that's what
        -- con2Tag returns (generated by untag_Expr)!
424

425 426 427 428
    tycon_data_cons = tyConDataCons tycon
    single_con_type = isSingleton tycon_data_cons
    (first_con : _) = tycon_data_cons
    (last_con : _)  = reverse tycon_data_cons
429 430
    first_tag       = get_tag first_con
    last_tag        = get_tag last_con
431

432
    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
433

434

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

439
    mkOrdOpRhs :: OrdOp -> LHsExpr RdrName
440
    mkOrdOpRhs op       -- RHS for comparing 'a' and 'b' according to op
441
      | length nullary_cons <= 2  -- Two nullary or fewer, so use cases
442
      = nlHsCase (nlHsVar a_RDR) $
443
        map (mkOrdOpAlt op) tycon_data_cons
444
        -- i.e.  case a of { C1 x y -> case b of C1 x y -> ....compare x,y...
445
        --                   C2 x   -> case b of C2 x -> ....comopare x.... }
446

447 448
      | null non_nullary_cons    -- All nullary, so go straight to comparing tags
      = mkTagCmp op
449

450
      | otherwise                -- Mixed nullary and non-nullary
451
      = nlHsCase (nlHsVar a_RDR) $
452
        (map (mkOrdOpAlt op) non_nullary_cons
453
         ++ [mkHsCaseAlt nlWildPat (mkTagCmp op)])
454

455

456
    mkOrdOpAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
457
    -- Make the alternative  (Ki a1 a2 .. av ->
458
    mkOrdOpAlt op data_con
459 460
      = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed)
                    (mkInnerRhs op data_con)
461 462 463 464 465 466 467 468 469 470
      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
471
                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
472
      | tag == last_tag
473
      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
474
                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
475

476
      | tag == first_tag + 1
477 478
      = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat first_con)
                                             (gtResult op)
479
                                 , mkInnerEqAlt op data_con
480
                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
481
      | tag == last_tag - 1
482 483
      = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat last_con)
                                             (ltResult op)
484
                                 , mkInnerEqAlt op data_con
485
                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
486

487
      | tag > last_tag `div` 2  -- lower range is larger
488
      = untag_Expr tycon [(b_RDR, bh_RDR)] $
489
        nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
490
               (gtResult op) $  -- Definitely GT
491
        nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
492
                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
493 494

      | otherwise               -- upper range is larger
495
      = untag_Expr tycon [(b_RDR, bh_RDR)] $
496
        nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
497
               (ltResult op) $  -- Definitely LT
498
        nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
499
                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
500
      where
501
        tag     = get_tag data_con
502
        tag_lit = noLoc (HsLit (HsIntPrim "" (toInteger tag)))
503

504
    mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
505 506 507
    -- 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
508
      = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $
509
        mkCompareFields tycon op (dataConOrigArgTys data_con)
510 511 512 513
      where
        data_con_RDR = getRdrName data_con
        bs_needed    = take (dataConSourceArity data_con) bs_RDRs

514
    mkTagCmp :: OrdOp -> LHsExpr RdrName
515 516 517 518
    -- 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
519

520 521 522 523 524 525 526 527
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:_)
528
      | isUnliftedType ty     = unliftedOrdOp tycon ty op a b
529
      | otherwise             = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)
530 531
    go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
                                  (ltResult op)
532
                                  (go tys as bs)
533
                                  (gtResult op)
534 535 536 537
    go _ _ _ = panic "mkCompareFields"

    -- (mk_compare ty a b) generates
    --    (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })
538
    -- but with suitable special cases for
539
    mk_compare ty a b lt eq gt
540
      | isUnliftedType ty
541
      = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
542
      | otherwise
543
      = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr))
544 545 546
          [mkHsCaseAlt (nlNullaryConPat ltTag_RDR) lt,
           mkHsCaseAlt (nlNullaryConPat eqTag_RDR) eq,
           mkHsCaseAlt (nlNullaryConPat gtTag_RDR) gt]
547 548 549 550 551 552 553 554
      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
555
       OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
556 557 558 559 560 561 562
                                     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
563
   wrap prim_op = genPrimOpApp a_expr prim_op b_expr
564 565 566
   a_expr = nlHsVar a
   b_expr = nlHsVar b

567
unliftedCompare :: RdrName -> RdrName
568
                -> LHsExpr RdrName -> LHsExpr RdrName   -- What to cmpare
569 570 571 572
                -> 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
573
  = nlHsIf (ascribeBool $ genPrimOpApp a_expr lt_op b_expr) lt $
Gabor Greif's avatar
typos  
Gabor Greif committed
574
                        -- Test (<) first, not (==), because the latter
575 576
                        -- is true less often, so putting it first would
                        -- mean more tests (dynamically)
577 578 579
        nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt
  where
    ascribeBool e = nlExprWithTySig e (toLHsSigWcType boolTy)
580 581 582 583

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

Austin Seipp's avatar
Austin Seipp committed
587 588 589
{-
************************************************************************
*                                                                      *
590
        Enum instances
Austin Seipp's avatar
Austin Seipp committed
591 592
*                                                                      *
************************************************************************
593 594 595 596 597 598 599 600 601 602 603

@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
604 605 606
    succ x   = toEnum (1 + fromEnum x)
    pred x   = toEnum (fromEnum x - 1)

607 608
    toEnum i = tag2con_Foo i

609 610 611 612 613
    enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]

    -- or, really...
    enumFrom a
      = case con2tag_Foo a of
614
          a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
615 616 617 618 619 620 621

   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# ->
622 623 624
        case con2tag_Foo b of { b# ->
        map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
        }}
625 626 627
\end{verbatim}

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

dreixel's avatar
dreixel committed
630
gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
631
gen_Enum_binds loc tycon
dreixel's avatar
dreixel committed
632
  = (method_binds, aux_binds)
633
  where
dreixel's avatar
dreixel committed
634
    method_binds = listToBag [
635 636 637 638 639 640 641
                        succ_enum,
                        pred_enum,
                        to_enum,
                        enum_from,
                        enum_from_then,
                        from_enum
                    ]
642 643
    aux_binds = listToBag $ map DerivAuxBind
                  [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
644

645
    occ_nm = getOccString tycon
sof's avatar
sof committed
646 647

    succ_enum
648
      = mk_easy_FunBind loc succ_RDR [a_Pat] $
649 650 651 652 653 654 655 656
        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
657
    pred_enum
658
      = mk_easy_FunBind loc pred_RDR [a_Pat] $
659 660 661 662 663 664
        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],
665
                                               nlHsLit (HsInt "-1" (-1))]))
666 667

    to_enum
668
      = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
669 670
        nlHsIf (nlHsApps and_RDR
                [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
671 672
                 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
             (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
673
             (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
674

675
    enum_from
676
      = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
677 678 679 680 681 682
          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)))]
683 684

    enum_from_then
685
      = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
686 687 688 689 690 691 692 693 694 695
          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))
                           ))
696 697

    from_enum
698
      = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
699 700
          untag_Expr tycon [(a_RDR, ah_RDR)] $
          (nlHsVarApps intDataCon_RDR [ah_RDR])
701

Austin Seipp's avatar
Austin Seipp committed
702 703 704
{-
************************************************************************
*                                                                      *
705
        Bounded instances
Austin Seipp's avatar
Austin Seipp committed
706 707 708
*                                                                      *
************************************************************************
-}
709

dreixel's avatar
dreixel committed
710
gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
711
gen_Bounded_binds loc tycon
712
  | isEnumerationTyCon tycon
dreixel's avatar
dreixel committed
713
  = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
714 715
  | otherwise
  = ASSERT(isSingleton data_cons)
dreixel's avatar
dreixel committed
716
    (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)
717
  where
718
    data_cons = tyConDataCons tycon
719 720

    ----- enum-flavored: ---------------------------
721 722
    min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
    max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
723

724 725
    data_con_1     = head data_cons
    data_con_N     = last data_cons
726 727
    data_con_1_RDR = getRdrName data_con_1
    data_con_N_RDR = getRdrName data_con_N
728 729

    ----- single-constructor-flavored: -------------
730
    arity          = dataConSourceArity data_con_1
731

732
    min_bound_1con = mkHsVarBind loc minBound_RDR $
733
                     nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
734
    max_bound_1con = mkHsVarBind loc maxBound_RDR $
735
                     nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
736

Austin Seipp's avatar
Austin Seipp committed
737 738 739
{-
************************************************************************
*                                                                      *
740
        Ix instances
Austin Seipp's avatar
Austin Seipp committed
741 742
*                                                                      *
************************************************************************
743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759

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# ->
760 761 762
        case (con2tag_Foo b) of { b# ->
        map tag2con_Foo (enumFromTo (I# a#) (I# b#))
        }}
763

Gabor Greif's avatar
typos  
Gabor Greif committed
764
    -- Generate code for unsafeIndex, because using index leads
765 766 767
    -- to lots of redundant range tests
    unsafeIndex c@(a, b) d
      = case (con2tag_Foo d -# con2tag_Foo a) of
768
               r# -> I# r#
769 770 771

    inRange (a, b) c
      = let
772 773 774
            p_tag = con2tag_Foo c
        in
        p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
775 776 777 778

    -- or, really...
    inRange (a, b) c
      = case (con2tag_Foo a)   of { a_tag ->
779 780 781 782 783 784 785
        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
        }}}
786
\end{verbatim}
787
(modulo suitable case-ification to handle the unlifted tags)
788 789 790 791 792 793 794

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
795
-}
796

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

799
gen_Ix_binds loc tycon
800
  | isEnumerationTyCon tycon
801 802 803
  = ( enum_ixes
    , listToBag $ map DerivAuxBind
                   [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
804
  | otherwise
805
  = (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))
806 807
  where
    --------------------------------------------------------------
dreixel's avatar
dreixel committed
808
    enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
809 810

    enum_range
811
      = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
812 813 814 815 816 817
          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]))
818 819

    enum_index
820 821 822 823 824 825 826 827 828 829 830
      = 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))
831
             [mkHsCaseAlt (nlVarPat c_RDR) rhs]
832 833
           ))
        )
834

835
    -- This produces something like `(ch >= ah) && (ch <= bh)`
836
    enum_inRange
837
      = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
838 839 840
          untag_Expr tycon [(a_RDR, ah_RDR)] (
          untag_Expr tycon [(b_RDR, bh_RDR)] (
          untag_Expr tycon [(c_RDR, ch_RDR)] (
841 842 843 844 845 846 847
          -- 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)
              ]
          )))
848 849

    --------------------------------------------------------------
850
    single_con_ixes
dreixel's avatar
dreixel committed
851
      = listToBag [single_con_range, single_con_index, single_con_inRange]
852 853

    data_con
854 855 856
      = case tyConSingleDataCon_maybe tycon of -- just checking...
          Nothing -> panic "get_Ix_binds"
          Just dc -> dc
857

858
    con_arity    = dataConSourceArity data_con
859
    data_con_RDR = getRdrName data_con
860

861 862 863
    as_needed = take con_arity as_RDRs
    bs_needed = take con_arity bs_RDRs
    cs_needed = take con_arity cs_RDRs
864

865 866
    con_pat  xs  = nlConVarPat data_con_RDR xs
    con_expr     = nlHsVarApps data_con_RDR cs_needed
sof's avatar
sof committed
867

868 869
    --------------------------------------------------------------
    single_con_range
870 871 872
      = mk_easy_FunBind loc range_RDR
          [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
        noLoc (mkHsComp ListComp stmts con_expr)
873
      where
874
        stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
875

876 877 878
        mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
                                 (nlHsApp (nlHsVar range_RDR)
                                          (mkLHsVarTuple [a,b]))