TcGenDeriv.hs 84.8 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
{-# LANGUAGE TypeFamilies #-}
18

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

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

38
#include "HsVersions.h"
39

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

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

78
import Data.List  ( partition, intersperse )
79

80 81
type BagDerivStuff = Bag DerivStuff

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

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

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

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

99

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

107 108 109 110 111 112 113 114 115
Here are the heuristics for the code we generate for @Eq@. Let's
assume we have a data type with some (possibly zero) nullary data
constructors and some ordinary, non-nullary ones (the rest, also
possibly zero of them).  Here's an example, with both \tr{N}ullary and
\tr{O}rdinary data cons.

  data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...

* For the ordinary constructors (if any), we emit clauses to do The
116 117
  Usual Thing, e.g.,:

118 119 120 121 122 123 124
    (==) (O1 a1 b1)    (O1 a2 b2)    = a1 == a2 && b1 == b2
    (==) (O2 a1)       (O2 a2)       = a1 == a2
    (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2

  Note: if we're comparing unlifted things, e.g., if 'a1' and
  'a2' are Float#s, then we have to generate
       case (a1 `eqFloat#` a2) of r -> r
125 126
  for that particular test.

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

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

135 136 137 138 139
  If con2tag gets inlined this leads to join point stuff, so
  it's better to use regular pattern matching if there aren't too
  many nullary constructors.  "Ten" is arbitrary, of course

* If there aren't any nullary constructors, we emit a simpler
140 141
  catch-all:

142
     (==) a b  = False
143

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

149 150 151 152 153 154 155 156
We thought about doing this: If we're also deriving 'Ord' for this
tycon, we generate:
  instance ... Eq (Foo ...) where
    (==) a b  = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
    (/=) a b  = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
However, that requires that (Ord <whatever>) was put in the context
for the instance decl, which it probably wasn't, so the decls
produced don't get through the typechecker.
Austin Seipp's avatar
Austin Seipp committed
157
-}
sof's avatar
sof committed
158

159
gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
Sylvain Henry's avatar
Sylvain Henry committed
160 161 162
gen_Eq_binds loc tycon = do
    dflags <- getDynFlags
    return (method_binds dflags, aux_binds)
163
  where
164 165 166 167 168 169 170 171 172
    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)
173

174
    no_tag_match_cons = null tag_match_cons
175

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

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

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

194 195
    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
196
                                            ++ fall_through_eqn dflags)
197

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

            data_con_RDR = getRdrName data_con
            con_arity   = length tys_needed
            as_needed   = take con_arity as_RDRs
            bs_needed   = take con_arity bs_RDRs
            tys_needed  = dataConOrigArgTys data_con
        in
        ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
211
      where
212 213 214 215 216
        nested_eq_expr []  [] [] = true_Expr
        nested_eq_expr tys as bs
          = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
          where
            nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
217

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

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

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

* To make rhs_i
239 240
     If i = 1, 2, n-1, n, generate a single case.
        rhs_2    case b of
241 242 243 244 245 246 247 248
                   K1 {}  -> LT
                   K2 ... -> ...eq_rhs(K2)...
                   _      -> GT

     Otherwise do a tag compare against the bigger range
     (because this is the one most likely to succeed)
        rhs_3    case tag b of tb ->
                 if 3 <# tg then GT
249
                 else case b of
250 251 252
                         K3 ... -> ...eq_rhs(K3)....
                         _      -> LT

253
* To make eq_rhs(K), which knows that
254 255 256 257 258 259
    a = K a1 .. av
    b = K b1 .. bv
  we just want to compare (a1,b1) then (a2,b2) etc.
  Take care on the last field to tail-call into comparing av,bv

* To make nullary_rhs generate this
260 261
     case con2tag a of a# ->
     case con2tag b of ->
262 263 264 265 266 267 268
     a# `compare` b#

Several special cases:

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

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

272
Note [Game plan for deriving Ord]
273 274
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's a bad idea to define only 'compare', and build the other binary
Gabor Greif's avatar
Gabor Greif committed
275
comparisons on top of it; see Trac #2130, #4019.  Reason: we don't
276 277 278 279
want to laboriously make a three-way comparison, only to extract a
binary result, something like this:
     (>) (I# x) (I# y) = case <# x y of
                            True -> False
280
                            False -> case ==# x y of
281 282
                                       True  -> False
                                       False -> True
283

284 285 286 287 288 289 290
This being said, we can get away with generating full code only for
'compare' and '<' thus saving us generation of other three operators.
Other operators can be cheaply expressed through '<':
a <= b = not $ b < a
a > b = b < a
a >= b = not $ a < b

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

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

296 297 298 299 300 301 302 303 304 305 306 307 308
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

------------
309
ltResult :: OrdOp -> LHsExpr GhcPs
310 311 312 313 314 315 316 317
-- 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

------------
318
eqResult :: OrdOp -> LHsExpr GhcPs
319 320 321 322 323 324 325 326
-- 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

------------
327
gtResult :: OrdOp -> LHsExpr GhcPs
328 329 330 331 332 333 334 335
-- 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

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

348
        -- Note [Game plan for deriving Ord]
Sylvain Henry's avatar
Sylvain Henry committed
349 350 351 352 353 354
    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
355

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

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

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

375
    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
376

377

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

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

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

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

399

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

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

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

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

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

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

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

459
    mkTagCmp :: DynFlags -> OrdOp -> LHsExpr GhcPs
460 461
    -- 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
462 463 464
    mkTagCmp dflags op =
      untag_Expr dflags tycon[(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $
        unliftedOrdOp tycon intPrimTy op ah_RDR bh_RDR
465

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

    -- (mk_compare ty a b) generates
    --    (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })
484
    -- but with suitable special cases for
485
    mk_compare ty a b lt eq gt
486
      | isUnliftedType ty
487
      = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
488
      | otherwise
489
      = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr))
490 491 492
          [mkHsCaseAlt (nlNullaryConPat ltTag_RDR) lt,
           mkHsCaseAlt (nlNullaryConPat eqTag_RDR) eq,
           mkHsCaseAlt (nlNullaryConPat gtTag_RDR) gt]
493 494 495 496 497
      where
        a_expr = nlHsVar a
        b_expr = nlHsVar b
        (lt_op, _, eq_op, _, _) = primOrdOps "Ord" tycon ty

498
unliftedOrdOp :: TyCon -> Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs
499 500
unliftedOrdOp tycon ty op a b
  = case op of
501
       OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
502 503 504 505 506 507 508
                                     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
509
   wrap prim_op = genPrimOpApp a_expr prim_op b_expr
510 511 512
   a_expr = nlHsVar a
   b_expr = nlHsVar b

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

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

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

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

554 555
    toEnum i = tag2con_Foo i

556 557 558 559 560
    enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]

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

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

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

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

593
    occ_nm = getOccString tycon
sof's avatar
sof committed
594

Sylvain Henry's avatar
Sylvain Henry committed
595
    succ_enum dflags
596
      = mk_easy_FunBind loc succ_RDR [a_Pat] $
Sylvain Henry's avatar
Sylvain Henry committed
597 598
        untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
        nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR dflags tycon),
599 600
                               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
601
             (nlHsApp (nlHsVar (tag2con_RDR dflags tycon))
602 603 604
                    (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
                                        nlHsIntLit 1]))

Sylvain Henry's avatar
Sylvain Henry committed
605
    pred_enum dflags
606
      = mk_easy_FunBind loc pred_RDR [a_Pat] $
Sylvain Henry's avatar
Sylvain Henry committed
607
        untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
608 609 610
        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
611
             (nlHsApp (nlHsVar (tag2con_RDR dflags tycon))
612
                      (nlHsApps plus_RDR
613 614
                            [ nlHsVarApps intDataCon_RDR [ah_RDR]
                            , nlHsLit (HsInt def (mkIntegralLit (-1 :: Int)))]))
615

Sylvain Henry's avatar
Sylvain Henry committed
616
    to_enum dflags
617
      = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
618 619
        nlHsIf (nlHsApps and_RDR
                [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
Sylvain Henry's avatar
Sylvain Henry committed
620 621 622 623
                 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))
624

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

Sylvain Henry's avatar
Sylvain Henry committed
634
    enum_from_then dflags
635
      = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
Sylvain Henry's avatar
Sylvain Henry committed
636 637
          untag_Expr dflags tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
          nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $
638 639 640 641 642 643
            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
644
                           (nlHsVar (maxtag_RDR dflags tycon))
645
                           ))
646

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

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

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

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

674 675
    data_con_1     = head data_cons
    data_con_N     = last data_cons
676 677
    data_con_1_RDR = getRdrName data_con_1
    data_con_N_RDR = getRdrName data_con_N
678 679

    ----- single-constructor-flavored: -------------
680
    arity          = dataConSourceArity data_con_1
681

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

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

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

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

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

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

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
745
-}
746

747
gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
748

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

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

Sylvain Henry's avatar
Sylvain Henry committed
772
    enum_index dflags
773 774 775 776
      = 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
777 778
           untag_Expr dflags tycon [(a_RDR, ah_RDR)] (
           untag_Expr dflags tycon [(d_RDR, dh_RDR)] (
779 780 781 782 783
           let
                rhs = nlHsVarApps intDataCon_RDR [c_RDR]
           in
           nlHsCase
             (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
784
             [mkHsCaseAlt (nlVarPat c_RDR) rhs]
785 786
           ))
        )
787

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

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

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

811
    con_arity    = dataConSourceArity data_con
812
    data_con_RDR = getRdrName data_con
813

814 815 816
    as_needed = take con_arity as_RDRs
    bs_needed = take con_arity bs_RDRs
    cs_needed = take con_arity cs_RDRs
817

818 819
    con_pat  xs  = nlConVarPat data_con_RDR xs
    con_expr     = nlHsVarApps data_con_RDR cs_needed
sof's avatar
sof committed
820

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

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

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

    ------------------
    single_con_inRange
861 862 863
      = mk_easy_FunBind loc inRange_RDR
                [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
                 con_pat cs_needed] $
864 865 866 867 868 869
          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)
870
      where
871
        in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
872