TcGenDeriv.hs 92.5 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 41
import GhcPrelude

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

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

Michal Terepeta's avatar
Michal Terepeta committed
79
import Data.List  ( find, partition, intersperse )
80

81 82
type BagDerivStuff = Bag DerivStuff

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

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

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

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

100

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

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

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

Peter Trommler's avatar
Peter Trommler committed
128
* If there are a lot of (more than ten) nullary constructors, we emit a
129
  catch-all clause of the form:
130

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

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

143
     (==) a b  = False
144

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

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

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

175
    no_tag_match_cons = null tag_match_cons
176

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

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

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

195
    method_binds dflags = unitBag (eq_bind dflags)
196 197 198
    eq_bind dflags = mkFunBindEC 2 loc eq_RDR (const true_Expr)
                                 (map pats_etc pat_match_cons
                                   ++ fall_through_eqn dflags)
199

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

            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)
213
      where
214 215
        nested_eq_expr []  [] [] = true_Expr
        nested_eq_expr tys as bs
216 217
          = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
          -- Using 'foldr1' here ensures that the derived code is correctly
218
          -- associated. See #10859.
219
          where
Michal Terepeta's avatar
Michal Terepeta committed
220
            nested_eq ty a b = nlHsPar (eq_Expr ty (nlHsVar a) (nlHsVar b))
221

Austin Seipp's avatar
Austin Seipp committed
222 223 224
{-
************************************************************************
*                                                                      *
225
        Ord instances
Austin Seipp's avatar
Austin Seipp committed
226 227
*                                                                      *
************************************************************************
228

229 230
Note [Generating Ord instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
231
Suppose constructors are K1..Kn, and some are nullary.
232 233 234
The general form we generate is:

* Do case on first argument
235
        case a of
236 237 238 239 240 241 242
          K1 ... -> rhs_1
          K2 ... -> rhs_2
          ...
          Kn ... -> rhs_n
          _ -> nullary_rhs

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

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

Several special cases:

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

* Be careful about unlifted comparisons.  When comparing unboxed
273
  values we can't call the overloaded functions.
274 275
  See function unliftedOrdOp

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

288 289 290 291 292 293 294
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

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

Austin Seipp's avatar
Austin Seipp committed
298
-}
299

300 301 302 303 304 305 306 307 308 309 310 311 312
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

------------
313
ltResult :: OrdOp -> LHsExpr GhcPs
314 315 316 317 318 319 320 321
-- 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

------------
322
eqResult :: OrdOp -> LHsExpr GhcPs
323 324 325 326 327 328 329 330
-- 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

------------
331
gtResult :: OrdOp -> LHsExpr GhcPs
332 333 334 335 336 337 338 339
-- 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

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

352
        -- Note [Game plan for deriving Ord]
Sylvain Henry's avatar
Sylvain Henry committed
353 354 355 356 357 358
    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
359

360 361 362 363 364 365 366 367
    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)

368 369 370
    get_tag con = dataConTag con - fIRST_TAG
        -- We want *zero-based* tags, because that's what
        -- con2Tag returns (generated by untag_Expr)!
371

372 373 374 375
    tycon_data_cons = tyConDataCons tycon
    single_con_type = isSingleton tycon_data_cons
    (first_con : _) = tycon_data_cons
    (last_con : _)  = reverse tycon_data_cons
376 377
    first_tag       = get_tag first_con
    last_tag        = get_tag last_con
378

379
    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
380

381

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

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

395
      | null non_nullary_cons    -- All nullary, so go straight to comparing tags
Sylvain Henry's avatar
Sylvain Henry committed
396
      = mkTagCmp dflags op
397

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

403

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

Sylvain Henry's avatar
Sylvain Henry committed
414
    mkInnerRhs dflags op data_con
415 416 417 418 419
      | single_con_type
      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ]

      | tag == first_tag
      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
420
                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
421
      | tag == last_tag
422
      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
423
                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
424

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

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

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

453
    mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
454 455 456
    -- 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
457
      = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $
Michal Terepeta's avatar
Michal Terepeta committed
458
        mkCompareFields op (dataConOrigArgTys data_con)
459 460 461 462
      where
        data_con_RDR = getRdrName data_con
        bs_needed    = take (dataConSourceArity data_con) bs_RDRs

463
    mkTagCmp :: DynFlags -> OrdOp -> LHsExpr GhcPs
464
    -- Both constructors known to be nullary
465
    -- generates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#
Sylvain Henry's avatar
Sylvain Henry committed
466 467
    mkTagCmp dflags op =
      untag_Expr dflags tycon[(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $
Michal Terepeta's avatar
Michal Terepeta committed
468
        unliftedOrdOp intPrimTy op ah_RDR bh_RDR
469

Michal Terepeta's avatar
Michal Terepeta committed
470
mkCompareFields :: OrdOp -> [Type] -> LHsExpr GhcPs
471 472
-- Generates nested comparisons for (a1,a2...) against (b1,b2,...)
-- where the ai,bi have the given types
Michal Terepeta's avatar
Michal Terepeta committed
473
mkCompareFields op tys
474 475 476 477
  = go tys as_RDRs bs_RDRs
  where
    go []   _      _          = eqResult op
    go [ty] (a:_)  (b:_)
Michal Terepeta's avatar
Michal Terepeta committed
478
      | isUnliftedType ty     = unliftedOrdOp ty op a b
479
      | otherwise             = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)
480 481
    go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
                                  (ltResult op)
482
                                  (go tys as bs)
483
                                  (gtResult op)
484 485 486 487
    go _ _ _ = panic "mkCompareFields"

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

Michal Terepeta's avatar
Michal Terepeta committed
502 503
unliftedOrdOp :: Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs
unliftedOrdOp ty op a b
504
  = case op of
505
       OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
506 507 508 509 510 511
                                     ltTag_Expr eqTag_Expr gtTag_Expr
       OrdLT      -> wrap lt_op
       OrdLE      -> wrap le_op
       OrdGE      -> wrap ge_op
       OrdGT      -> wrap gt_op
  where
Michal Terepeta's avatar
Michal Terepeta committed
512
   (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" ty
513
   wrap prim_op = genPrimOpApp a_expr prim_op b_expr
514 515 516
   a_expr = nlHsVar a
   b_expr = nlHsVar b

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

532
nlConWildPat :: DataCon -> LPat GhcPs
533 534
-- The pattern (K {})
nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con))
535
                                   (RecCon (HsRecFields { rec_flds = []
536
                                                        , rec_dotdot = Nothing })))
537

Austin Seipp's avatar
Austin Seipp committed
538 539 540
{-
************************************************************************
*                                                                      *
541
        Enum instances
Austin Seipp's avatar
Austin Seipp committed
542 543
*                                                                      *
************************************************************************
544 545 546 547 548 549 550 551 552 553 554

@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
555 556 557
    succ x   = toEnum (1 + fromEnum x)
    pred x   = toEnum (fromEnum x - 1)

558 559
    toEnum i = tag2con_Foo i

560 561 562 563 564
    enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]

    -- or, really...
    enumFrom a
      = case con2tag_Foo a of
565
          a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
566 567 568 569 570 571 572

   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# ->
573 574 575
        case con2tag_Foo b of { b# ->
        map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
        }}
576 577 578
\end{verbatim}

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

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

597
    occ_nm = getOccString tycon
sof's avatar
sof committed
598

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

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

Sylvain Henry's avatar
Sylvain Henry committed
621
    to_enum dflags
622
      = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
623 624
        nlHsIf (nlHsApps and_RDR
                [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
Sylvain Henry's avatar
Sylvain Henry committed
625 626 627 628
                 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))
629

Sylvain Henry's avatar
Sylvain Henry committed
630
    enum_from dflags
631
      = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
Sylvain Henry's avatar
Sylvain Henry committed
632
          untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
633
          nlHsApps map_RDR
Sylvain Henry's avatar
Sylvain Henry committed
634
                [nlHsVar (tag2con_RDR dflags tycon),
635 636
                 nlHsPar (enum_from_to_Expr
                            (nlHsVarApps intDataCon_RDR [ah_RDR])
Sylvain Henry's avatar
Sylvain Henry committed
637
                            (nlHsVar (maxtag_RDR dflags tycon)))]
638

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

Sylvain Henry's avatar
Sylvain Henry committed
652
    from_enum dflags
653
      = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
Sylvain Henry's avatar
Sylvain Henry committed
654
          untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
655
          (nlHsVarApps intDataCon_RDR [ah_RDR])
656

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

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

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

679 680
    data_con_1     = head data_cons
    data_con_N     = last data_cons
681 682
    data_con_1_RDR = getRdrName data_con_1
    data_con_N_RDR = getRdrName data_con_N
683 684

    ----- single-constructor-flavored: -------------
685
    arity          = dataConSourceArity data_con_1
686

687
    min_bound_1con = mkHsVarBind loc minBound_RDR $
688
                     nlHsVarApps data_con_1_RDR (replicate arity minBound_RDR)
689
    max_bound_1con = mkHsVarBind loc maxBound_RDR $
690
                     nlHsVarApps data_con_1_RDR (replicate arity maxBound_RDR)
691

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

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

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

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

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

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
750
-}
751

752
gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
753

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

Sylvain Henry's avatar
Sylvain Henry committed
768
    enum_range dflags
769
      = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
Sylvain Henry's avatar
Sylvain Henry committed
770 771 772
          untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
          untag_Expr dflags tycon [(b_RDR, bh_RDR)] $
          nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $
773 774 775
              nlHsPar (enum_from_to_Expr
                        (nlHsVarApps intDataCon_RDR [ah_RDR])
                        (nlHsVarApps intDataCon_RDR [bh_RDR]))
776

Sylvain Henry's avatar
Sylvain Henry committed
777
    enum_index dflags
778
      = mk_easy_FunBind loc unsafeIndex_RDR
779
                [noLoc (AsPat noExt (noLoc c_RDR)
780 781
                           (nlTuplePat [a_Pat, nlWildPat] Boxed)),
                                d_Pat] (
Sylvain Henry's avatar
Sylvain Henry committed
782 783
           untag_Expr dflags tycon [(a_RDR, ah_RDR)] (
           untag_Expr dflags tycon [(d_RDR, dh_RDR)] (
784 785 786 787 788
           let
                rhs = nlHsVarApps intDataCon_RDR [c_RDR]
           in
           nlHsCase
             (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
789
             [mkHsCaseAlt (nlVarPat c_RDR) rhs]
790 791
           ))
        )
792

793
    -- This produces something like `(ch >= ah) && (ch <= bh)`
Sylvain Henry's avatar
Sylvain Henry committed
794
    enum_inRange dfla