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

6 7

TcGenDeriv: Generating derived instance declarations
8 9 10 11 12

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

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

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

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,
34
        mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, 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

77
import Data.List  ( partition, intersperse )
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

98

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

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

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

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

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

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

141
     (==) a b  = False
142

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

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

Sylvain Henry's avatar
Sylvain Henry committed
158 159 160 161
gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff)
gen_Eq_binds loc tycon = do
    dflags <- getDynFlags
    return (method_binds dflags, 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

Sylvain Henry's avatar
Sylvain Henry committed
175
    fall_through_eqn dflags
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],
Sylvain Henry's avatar
Sylvain Henry committed
187
         untag_Expr dflags 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

193 194
    method_binds dflags = unitBag (eq_bind dflags)
    eq_bind dflags = mkFunBindSE 2 loc eq_RDR (map pats_etc pat_match_cons
Sylvain Henry's avatar
Sylvain Henry committed
195
                                            ++ fall_through_eqn dflags)
196

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

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

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

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

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

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

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

Several special cases:

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

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

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

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

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

Austin Seipp's avatar
Austin Seipp committed
293
-}
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
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

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

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

355 356 357 358 359 360 361 362
    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)

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

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

374
    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
375

376

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

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

390
      | null non_nullary_cons    -- All nullary, so go straight to comparing tags
Sylvain Henry's avatar
Sylvain Henry committed
391
      = mkTagCmp dflags op
392

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

398

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

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

      | tag == first_tag
      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
415
                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
416
      | tag == last_tag
417
      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
418
                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
419

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

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

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

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

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

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

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

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

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

Austin Seipp's avatar
Austin Seipp committed
532 533 534
{-
************************************************************************
*                                                                      *
535
        Enum instances
Austin Seipp's avatar
Austin Seipp committed
536 537
*                                                                      *
************************************************************************
538 539 540 541 542 543 544 545 546 547 548

@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
549 550 551
    succ x   = toEnum (1 + fromEnum x)
    pred x   = toEnum (fromEnum x - 1)

552 553
    toEnum i = tag2con_Foo i

554 555 556 557 558
    enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]

    -- or, really...
    enumFrom a
      = case con2tag_Foo a of
559
          a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
560 561 562 563 564 565 566

   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# ->
567 568 569
        case con2tag_Foo b of { b# ->
        map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
        }}
570 571 572
\end{verbatim}

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

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

591
    occ_nm = getOccString tycon
sof's avatar
sof committed
592

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

Sylvain Henry's avatar
Sylvain Henry committed
603
    pred_enum dflags
604
      = mk_easy_FunBind loc pred_RDR [a_Pat] $
Sylvain Henry's avatar
Sylvain Henry committed
605
        untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
606 607 608
        nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
                               nlHsVarApps intDataCon_RDR [ah_RDR]])
             (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
Sylvain Henry's avatar
Sylvain Henry committed
609
             (nlHsApp (nlHsVar (tag2con_RDR dflags tycon))
610 611 612
                      (nlHsApps plus_RDR
                                [ nlHsVarApps intDataCon_RDR [ah_RDR]
                                , nlHsLit (HsInt (mkIntegralLit (-1 :: Int)))]))
613

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

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

Sylvain Henry's avatar
Sylvain Henry committed
632
    enum_from_then dflags
633
      = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
Sylvain Henry's avatar
Sylvain Henry committed
634 635
          untag_Expr dflags tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
          nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $
636 637 638 639 640 641
            nlHsPar (enum_from_then_to_Expr
                    (nlHsVarApps intDataCon_RDR [ah_RDR])
                    (nlHsVarApps intDataCon_RDR [bh_RDR])
                    (nlHsIf  (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
                                               nlHsVarApps intDataCon_RDR [bh_RDR]])
                           (nlHsIntLit 0)
Sylvain Henry's avatar
Sylvain Henry committed
642
                           (nlHsVar (maxtag_RDR dflags tycon))
643
                           ))
644

Sylvain Henry's avatar
Sylvain Henry committed
645
    from_enum dflags
646
      = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
Sylvain Henry's avatar
Sylvain Henry committed
647
          untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
648
          (nlHsVarApps intDataCon_RDR [ah_RDR])
649

Austin Seipp's avatar
Austin Seipp committed
650 651 652
{-
************************************************************************
*                                                                      *
653
        Bounded instances
Austin Seipp's avatar
Austin Seipp committed
654 655 656
*                                                                      *
************************************************************************
-}
657

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

    ----- enum-flavored: ---------------------------
669 670
    min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
    max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
671

672 673
    data_con_1     = head data_cons
    data_con_N     = last data_cons
674 675
    data_con_1_RDR = getRdrName data_con_1
    data_con_N_RDR = getRdrName data_con_N
676 677

    ----- single-constructor-flavored: -------------
678
    arity          = dataConSourceArity data_con_1
679

680
    min_bound_1con = mkHsVarBind loc minBound_RDR $
681
                     nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
682
    max_bound_1con = mkHsVarBind loc maxBound_RDR $
683
                     nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
684

Austin Seipp's avatar
Austin Seipp committed
685 686 687
{-
************************************************************************
*                                                                      *
688
        Ix instances
Austin Seipp's avatar
Austin Seipp committed
689 690
*                                                                      *
************************************************************************
691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707

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# ->
708 709 710
        case (con2tag_Foo b) of { b# ->
        map tag2con_Foo (enumFromTo (I# a#) (I# b#))
        }}
711

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

    inRange (a, b) c
      = let
720 721 722
            p_tag = con2tag_Foo c
        in
        p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
723 724 725 726

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

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
743
-}
744

Sylvain Henry's avatar
Sylvain Henry committed
745
gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff)
746

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

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

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

786
    -- This produces something like `(ch >= ah) && (ch <= bh)`
Sylvain Henry's avatar
Sylvain Henry committed
787
    enum_inRange dflags
788
      = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
Sylvain Henry's avatar
Sylvain Henry committed
789 790 791
          untag_Expr dflags tycon [(a_RDR, ah_RDR)] (
          untag_Expr dflags tycon [(b_RDR, bh_RDR)] (
          untag_Expr dflags tycon [(c_RDR, ch_RDR)] (
792 793 794 795 796 797 798
          -- 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)
              ]
          )))
799 800

    --------------------------------------------------------------
801
    single_con_ixes
dreixel's avatar
dreixel committed
802
      = listToBag [single_con_range, single_con_index, single_con_inRange]
803 804

    data_con
805 806 807
      = case tyConSingleDataCon_maybe tycon of -- just checking...
          Nothing -> panic "get_Ix_binds"
          Just dc -> dc
808

809
    con_arity    = dataConSourceArity data_con
810
    data_con_RDR = getRdrName data_con
811

812 813 814
    as_needed = take con_arity as_RDRs
    bs_needed = take con_arity bs_RDRs
    cs_needed = take con_arity cs_RDRs
815

816 817
    con_pat  xs  = nlConVarPat data_con_RDR xs
    con_expr     = nlHsVarApps data_con_RDR cs_needed
sof's avatar
sof committed
818

819 820
    --------------------------------------------------------------
    single_con_range
821 822 823
      = mk_easy_FunBind loc range_RDR
          [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
        noLoc (mkHsComp ListComp stmts con_expr)
824
      where
825
        stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
826

827 828 829
        mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
                                 (nlHsApp (nlHsVar range_RDR)
                                          (mkLHsVarTuple [a,b]))
830 831 832

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

    ------------------
    single_con_inRange
859 860 861
      = mk_easy_FunBind loc inRange_RDR
                [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
                 con_pat cs_needed] $
862 863 864 865 866 867
          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)
partain's avatar